ff1c11577b44fa93d8e155e4634c0bd9dae432f0
[ghc.git] / compiler / main / HscMain.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
3 %
4
5 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
6
7 \begin{code}
8 module HscMain
9     ( newHscEnv, hscCmmFile
10     , hscParseIdentifier
11 #ifdef GHCI
12     , hscStmt, hscTcExpr, hscKcType
13     , compileExpr
14 #endif
15     , hscCompileOneShot     -- :: Compiler HscStatus
16     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
17     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
18     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
19     , HscStatus (..)
20     , InteractiveStatus (..)
21
22     -- The new interface
23     , parseFile
24     , typecheckModule
25     , typecheckRenameModule
26     , deSugarModule
27     , makeSimpleIface
28     , makeSimpleDetails
29     ) where
30
31 #include "HsVersions.h"
32
33 #ifdef GHCI
34 import CodeOutput       ( outputForeignStubs )
35 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
36 import Linker           ( HValue, linkExpr )
37 import CoreTidy         ( tidyExpr )
38 import CorePrep         ( corePrepExpr )
39 import Flattening       ( flattenExpr )
40 import Desugar          ( deSugarExpr )
41 import SimplCore        ( simplifyExpr )
42 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType ) 
43 import Type             ( Type )
44 import PrelNames        ( iNTERACTIVE )
45 import {- Kind parts of -} Type         ( Kind )
46 import CoreLint         ( lintUnfolding )
47 import DsMeta           ( templateHaskellNames )
48 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
49 import VarSet
50 import VarEnv           ( emptyTidyEnv )
51 #endif
52
53 import Var              ( Id )
54 import Module           ( emptyModuleEnv, ModLocation(..), Module )
55 import RdrName
56 import HsSyn
57 import CoreSyn
58 import SrcLoc           ( Located(..) )
59 import StringBuffer
60 import Parser
61 import Lexer
62 import SrcLoc           ( mkSrcLoc )
63 import TcRnDriver       ( tcRnModule, tcRnExtCore )
64 import TcIface          ( typecheckIface )
65 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
66 import IfaceEnv         ( initNameCache )
67 import LoadIface        ( ifaceStats, initExternalPackageState )
68 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
69 import MkIface
70 import Desugar          ( deSugar )
71 import SimplCore        ( core2core )
72 import TidyPgm
73 import CorePrep         ( corePrepPgm )
74 import CoreToStg        ( coreToStg )
75 import StgSyn
76 import CostCentre
77 import TyCon            ( isDataTyCon )
78 import Name             ( Name, NamedThing(..) )
79 import SimplStg         ( stg2stg )
80 import CodeGen          ( codeGen )
81 import Cmm              ( Cmm )
82 import CmmParse         ( parseCmmFile )
83 import CmmCPS
84 import CmmCPSZ
85 import CmmInfo
86 import CmmCvt
87 import CmmTx
88 import CmmContFlowOpt
89 import CodeOutput       ( codeOutput )
90 import NameEnv          ( emptyNameEnv )
91
92 import DynFlags
93 import ErrUtils
94 import UniqSupply       ( mkSplitUniqSupply )
95
96 import Outputable
97 import HscStats         ( ppSourceStats )
98 import HscTypes
99 import MkExternalCore   ( emitExternalCore )
100 import ParserCore
101 import ParserCoreUtils
102 import FastString
103 import UniqFM           ( emptyUFM )
104 import UniqSupply       ( initUs_ )
105 import Bag              ( unitBag )
106
107 import Control.Monad
108 import System.Exit
109 import System.IO
110 import Data.IORef
111 \end{code}
112
113
114 %************************************************************************
115 %*                                                                      *
116                 Initialisation
117 %*                                                                      *
118 %************************************************************************
119
120 \begin{code}
121 newHscEnv :: DynFlags -> IO HscEnv
122 newHscEnv dflags
123   = do  { eps_var <- newIORef initExternalPackageState
124         ; us      <- mkSplitUniqSupply 'r'
125         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
126         ; fc_var  <- newIORef emptyUFM
127         ; mlc_var  <- newIORef emptyModuleEnv
128         ; return (HscEnv { hsc_dflags = dflags,
129                            hsc_targets = [],
130                            hsc_mod_graph = [],
131                            hsc_IC     = emptyInteractiveContext,
132                            hsc_HPT    = emptyHomePackageTable,
133                            hsc_EPS    = eps_var,
134                            hsc_NC     = nc_var,
135                            hsc_FC     = fc_var,
136                            hsc_MLC    = mlc_var,
137                            hsc_global_rdr_env = emptyGlobalRdrEnv,
138                            hsc_global_type_env = emptyNameEnv } ) }
139                         
140
141 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
142                         -- where templateHaskellNames are defined
143 knownKeyNames = map getName wiredInThings 
144               ++ basicKnownKeyNames
145 #ifdef GHCI
146               ++ templateHaskellNames
147 #endif
148 \end{code}
149
150
151 \begin{code}
152 -- | parse a file, returning the abstract syntax
153 parseFile :: HscEnv -> ModSummary -> IO (Maybe (Located (HsModule RdrName)))
154 parseFile hsc_env mod_summary
155  = do 
156        maybe_parsed <- myParseModule dflags hspp_file hspp_buf
157        case maybe_parsed of
158          Left err
159              -> do printBagOfErrors dflags (unitBag err)
160                    return Nothing
161          Right rdr_module
162              -> return (Just rdr_module)
163   where
164            dflags    = hsc_dflags hsc_env
165            hspp_file = ms_hspp_file mod_summary
166            hspp_buf  = ms_hspp_buf  mod_summary
167
168 -- | Rename and typecheck a module
169 typecheckModule :: HscEnv -> ModSummary -> Located (HsModule RdrName)
170                 -> IO (Maybe TcGblEnv)
171 typecheckModule hsc_env mod_summary rdr_module
172  = do 
173         (tc_msgs, maybe_tc_result) 
174                 <- {-# SCC "Typecheck-Rename" #-}
175                    tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
176         printErrorsAndWarnings dflags tc_msgs
177         return maybe_tc_result
178   where
179         dflags = hsc_dflags hsc_env
180
181 type RenamedStuff = 
182         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
183                 Maybe (HsDoc Name), HaddockModInfo Name))
184
185 -- | Rename and typecheck a module, additinoally returning the renamed syntax
186 typecheckRenameModule :: HscEnv -> ModSummary -> Located (HsModule RdrName)
187                 -> IO (Maybe (TcGblEnv, RenamedStuff))
188 typecheckRenameModule hsc_env mod_summary rdr_module
189  = do 
190         (tc_msgs, maybe_tc_result) 
191                 <- {-# SCC "Typecheck-Rename" #-}
192                    tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
193         printErrorsAndWarnings dflags tc_msgs
194         case maybe_tc_result of
195            Nothing -> return Nothing
196            Just tc_result -> do
197               let rn_info = do decl <- tcg_rn_decls tc_result
198                                imports <- tcg_rn_imports tc_result
199                                let exports = tcg_rn_exports tc_result
200                                let doc = tcg_doc tc_result
201                                let hmi = tcg_hmi tc_result
202                                return (decl,imports,exports,doc,hmi)
203               return (Just (tc_result, rn_info))
204   where
205         dflags = hsc_dflags hsc_env
206
207 -- | Convert a typechecked module to Core
208 deSugarModule :: HscEnv -> ModSummary -> TcGblEnv -> IO (Maybe ModGuts)
209 deSugarModule hsc_env mod_summary tc_result
210  = deSugar hsc_env (ms_location mod_summary) tc_result
211
212 -- | Make a 'ModIface' from the results of typechecking.  Used when
213 -- not optimising, and the interface doesn't need to contain any
214 -- unfoldings or other cross-module optimisation info.
215 -- ToDo: the old interface is only needed to get the version numbers,
216 -- we should use fingerprint versions instead.
217 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
218                 -> IO (ModIface,Bool)
219 makeSimpleIface hsc_env maybe_old_iface tc_result details = do
220   mkIfaceTc hsc_env maybe_old_iface details tc_result
221
222 -- | Make a 'ModDetails' from the results of typechecking.  Used when
223 -- typechecking only, as opposed to full compilation.
224 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
225 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
226
227 -- deSugarModule :: HscEnv -> TcGblEnv -> IO Core
228 \end{code}
229
230 %************************************************************************
231 %*                                                                      *
232                 The main compiler pipeline
233 %*                                                                      *
234 %************************************************************************
235
236                    --------------------------------
237                         The compilation proper
238                    --------------------------------
239
240
241 It's the task of the compilation proper to compile Haskell, hs-boot and
242 core files to either byte-code, hard-code (C, asm, Java, ect) or to
243 nothing at all (the module is still parsed and type-checked. This
244 feature is mostly used by IDE's and the likes).
245 Compilation can happen in either 'one-shot', 'batch', 'nothing',
246 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
247 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
248 targets byte-code.
249 The modes are kept separate because of their different types and meanings.
250 In 'one-shot' mode, we're only compiling a single file and can therefore
251 discard the new ModIface and ModDetails. This is also the reason it only
252 targets hard-code; compiling to byte-code or nothing doesn't make sense
253 when we discard the result.
254 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
255 and ModDetails. 'Batch' mode doesn't target byte-code since that require
256 us to return the newly compiled byte-code.
257 'Nothing' mode has exactly the same type as 'batch' mode but they're still
258 kept separate. This is because compiling to nothing is fairly special: We
259 don't output any interface files, we don't run the simplifier and we don't
260 generate any code.
261 'Interactive' mode is similar to 'batch' mode except that we return the
262 compiled byte-code together with the ModIface and ModDetails.
263
264 Trying to compile a hs-boot file to byte-code will result in a run-time
265 error. This is the only thing that isn't caught by the type-system.
266
267 \begin{code}
268
269 -- Status of a compilation to hard-code or nothing.
270 data HscStatus
271     = HscNoRecomp
272     | HscRecomp  Bool -- Has stub files.
273                       -- This is a hack. We can't compile C files here
274                       -- since it's done in DriverPipeline. For now we
275                       -- just return True if we want the caller to compile
276                       -- them for us.
277
278 -- Status of a compilation to byte-code.
279 data InteractiveStatus
280     = InteractiveNoRecomp
281     | InteractiveRecomp Bool     -- Same as HscStatus
282                         CompiledByteCode
283                         ModBreaks
284
285
286 -- I want Control.Monad.State! --Lemmih 03/07/2006
287 newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)}
288
289 instance Monad Comp where
290     g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s'
291     return a = Comp $ \s -> return (a,s)
292     fail = error
293
294 evalComp :: Comp a -> CompState -> IO a
295 evalComp comp st = do (val,_st') <- runComp comp st
296                       return val
297
298 data CompState
299     = CompState
300     { compHscEnv     :: HscEnv
301     , compModSummary :: ModSummary
302     , compOldIface   :: Maybe ModIface
303     }
304
305 get :: Comp CompState
306 get = Comp $ \s -> return (s,s)
307
308 modify :: (CompState -> CompState) -> Comp ()
309 modify f = Comp $ \s -> return ((), f s)
310
311 gets :: (CompState -> a) -> Comp a
312 gets getter = do st <- get
313                  return (getter st)
314
315 liftIO :: IO a -> Comp a
316 liftIO ioA = Comp $ \s -> do a <- ioA
317                              return (a,s)
318
319 type NoRecomp result = ModIface -> Comp result
320
321 -- FIXME: The old interface and module index are only using in 'batch' and
322 --        'interactive' mode. They should be removed from 'oneshot' mode.
323 type Compiler result =  HscEnv
324                      -> ModSummary
325                      -> Bool                -- True <=> source unchanged
326                      -> Maybe ModIface      -- Old interface, if available
327                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
328                      -> IO (Maybe result)
329
330 --------------------------------------------------------------
331 -- Compilers
332 --------------------------------------------------------------
333
334 -- Compile Haskell, boot and extCore in OneShot mode.
335 hscCompileOneShot :: Compiler HscStatus
336 hscCompileOneShot
337    = hscCompiler norecompOneShot oneShotMsg backend boot_backend
338    where
339      backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
340      boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (HscRecomp False)
341
342 -- Compile Haskell, boot and extCore in batch mode.
343 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
344 hscCompileBatch
345    = hscCompiler norecompBatch batchMsg backend boot_backend
346    where
347      backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch
348      boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
349
350 -- Type-check Haskell, boot and extCore.
351 -- Does it make sense to compile extCore to nothing?
352 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
353 hscCompileNothing
354    = hscCompiler norecompBatch batchMsg backend backend
355    where
356      backend inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing
357
358 -- Compile Haskell, extCore to bytecode.
359 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
360 hscCompileInteractive
361    = hscCompiler norecompInteractive batchMsg backend boot_backend
362    where
363      backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
364      boot_backend = panic "hscCompileInteractive: can't do boot files here"
365
366 hscCompiler
367         :: NoRecomp result                                  -- No recomp necessary
368         -> (Maybe (Int,Int) -> Bool -> Comp ())             -- Message callback
369         -> (ModGuts -> Comp result)  -- Compile normal file
370         -> (ModGuts -> Comp result) -- Compile boot file
371         -> Compiler result
372 hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary 
373             source_unchanged mbOldIface mbModIndex
374     = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
375       do (recomp_reqd, mbCheckedIface)
376              <- {-# SCC "checkOldIface" #-}
377                 liftIO $ checkOldIface hsc_env mod_summary
378                               source_unchanged mbOldIface
379          -- save the interface that comes back from checkOldIface.
380          -- In one-shot mode we don't have the old iface until this
381          -- point, when checkOldIface reads it from the disk.
382          modify (\s -> s{ compOldIface = mbCheckedIface })
383          case mbCheckedIface of 
384            Just iface | not recomp_reqd
385                -> do messenger mbModIndex False
386                      result <- norecomp iface
387                      return (Just result)
388            _otherwise
389                -> do messenger mbModIndex True
390                      mb_modguts <- frontend
391                      case mb_modguts of
392                        Nothing
393                            -> return Nothing
394                        Just core
395                            -> do result <- backend core
396                                  return (Just result)
397     where
398           frontend :: Comp (Maybe ModGuts)       -- Front end
399           -- backend  :: (ModGuts -> Comp result)   -- Backend.
400           (frontend,backend)
401               = case ms_hsc_src mod_summary of
402                 ExtCoreFile -> (hscCoreFrontEnd, nonBootComp)
403                 HsSrcFile   -> (hscFileFrontEnd, nonBootComp)
404                 HsBootFile  -> (hscFileFrontEnd, bootComp)
405
406 --------------------------------------------------------------
407 -- NoRecomp handlers
408 --------------------------------------------------------------
409
410 norecompOneShot :: NoRecomp HscStatus
411 norecompOneShot _old_iface
412     = do hsc_env <- gets compHscEnv
413          liftIO $ do
414          dumpIfaceStats hsc_env
415          return HscNoRecomp
416
417 norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
418 norecompBatch = norecompWorker HscNoRecomp False
419
420 norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
421 norecompInteractive = norecompWorker InteractiveNoRecomp True
422
423 norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
424 norecompWorker a _isInterp old_iface
425     = do hsc_env <- gets compHscEnv
426          _mod_summary <- gets compModSummary
427          liftIO $ do
428          new_details <- {-# SCC "tcRnIface" #-}
429                         initIfaceCheck hsc_env $
430                         typecheckIface old_iface
431          dumpIfaceStats hsc_env
432          return (a, old_iface, new_details)
433
434 --------------------------------------------------------------
435 -- Progress displayers.
436 --------------------------------------------------------------
437
438 oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp ()
439 oneShotMsg _mb_mod_index recomp
440     = do hsc_env <- gets compHscEnv
441          liftIO $ do
442          if recomp
443             then return ()
444             else compilationProgressMsg (hsc_dflags hsc_env) $
445                      "compilation IS NOT required"
446
447 batchMsg :: Maybe (Int,Int) -> Bool -> Comp ()
448 batchMsg mb_mod_index recomp
449     = do hsc_env <- gets compHscEnv
450          mod_summary <- gets compModSummary
451          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
452                            (showModuleIndex mb_mod_index ++
453                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
454          liftIO $ do
455          if recomp
456             then showMsg "Compiling "
457             else if verbosity (hsc_dflags hsc_env) >= 2
458                     then showMsg "Skipping  "
459                     else return ()
460
461 --------------------------------------------------------------
462 -- FrontEnds
463 --------------------------------------------------------------
464
465 hscCoreFrontEnd :: Comp (Maybe ModGuts)
466 hscCoreFrontEnd =
467     do hsc_env <- gets compHscEnv
468        mod_summary <- gets compModSummary
469        liftIO $ do
470             -------------------
471             -- PARSE
472             -------------------
473        inp <- readFile (ms_hspp_file mod_summary)
474        case parseCore inp 1 of
475          FailP s
476              -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
477                    return Nothing
478          OkP rdr_module
479              -------------------
480              -- RENAME and TYPECHECK
481              -------------------
482              -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
483                                                  tcRnExtCore hsc_env rdr_module
484                    printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
485                    case maybe_tc_result of
486                      Nothing       -> return Nothing
487                      Just mod_guts -> return (Just mod_guts)         -- No desugaring to do!
488
489          
490 hscFileFrontEnd :: Comp (Maybe ModGuts)
491 hscFileFrontEnd =
492     do hsc_env <- gets compHscEnv
493        mod_summary <- gets compModSummary
494        liftIO $ do
495              -------------------
496              -- PARSE
497              -------------------
498        let dflags = hsc_dflags hsc_env
499            hspp_file = ms_hspp_file mod_summary
500            hspp_buf  = ms_hspp_buf  mod_summary
501        maybe_parsed <- myParseModule dflags hspp_file hspp_buf
502        case maybe_parsed of
503          Left err
504              -> do printBagOfErrors dflags (unitBag err)
505                    return Nothing
506          Right rdr_module
507              -------------------
508              -- RENAME and TYPECHECK
509              -------------------
510              -> do (tc_msgs, maybe_tc_result) 
511                        <- {-# SCC "Typecheck-Rename" #-}
512                           tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
513                    printErrorsAndWarnings dflags tc_msgs
514                    case maybe_tc_result of
515                      Nothing
516                          -> return Nothing
517                      Just tc_result
518                          -------------------
519                          -- DESUGAR
520                          -------------------
521                          -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result
522
523 --------------------------------------------------------------
524 -- Simplifiers
525 --------------------------------------------------------------
526
527 hscSimplify :: ModGuts -> Comp ModGuts
528 hscSimplify ds_result
529   = do hsc_env <- gets compHscEnv
530        liftIO $ do
531            -------------------
532            -- SIMPLIFY
533            -------------------
534        simpl_result <- {-# SCC "Core2Core" #-}
535                        core2core hsc_env ds_result
536        return simpl_result
537
538 --------------------------------------------------------------
539 -- Interface generators
540 --------------------------------------------------------------
541
542 -- HACK: we return ModGuts even though we know it's not gonna be used.
543 --       We do this because the type signature needs to be identical
544 --       in structure to the type of 'hscNormalIface'.
545 hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
546 hscSimpleIface ds_result
547   = do hsc_env <- gets compHscEnv
548        _mod_summary <- gets compModSummary
549        maybe_old_iface <- gets compOldIface
550        liftIO $ do
551        details <- mkBootModDetailsDs hsc_env ds_result
552        (new_iface, no_change) 
553            <- {-# SCC "MkFinalIface" #-}
554               mkIface hsc_env maybe_old_iface details ds_result
555        -- And the answer is ...
556        dumpIfaceStats hsc_env
557        return (new_iface, no_change, details, ds_result)
558
559 hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
560 hscNormalIface simpl_result
561   = do hsc_env <- gets compHscEnv
562        _mod_summary <- gets compModSummary
563        maybe_old_iface <- gets compOldIface
564        liftIO $ do
565             -------------------
566             -- TIDY
567             -------------------
568        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
569                              tidyProgram hsc_env simpl_result
570
571             -------------------
572             -- BUILD THE NEW ModIface and ModDetails
573             --  and emit external core if necessary
574             -- This has to happen *after* code gen so that the back-end
575             -- info has been set.  Not yet clear if it matters waiting
576             -- until after code output
577        (new_iface, no_change)
578                 <- {-# SCC "MkFinalIface" #-}
579                    mkIface hsc_env maybe_old_iface details simpl_result
580         -- Emit external core
581        emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006
582        dumpIfaceStats hsc_env
583
584             -------------------
585             -- Return the prepared code.
586        return (new_iface, no_change, details, cg_guts)
587
588 --------------------------------------------------------------
589 -- BackEnd combinators
590 --------------------------------------------------------------
591
592 hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
593 hscWriteIface (iface, no_change, details, a)
594     = do mod_summary <- gets compModSummary
595          hsc_env <- gets compHscEnv
596          let dflags = hsc_dflags hsc_env
597          liftIO $ do
598          unless no_change
599            $ writeIfaceFile dflags (ms_location mod_summary) iface
600          return (iface, details, a)
601
602 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
603 hscIgnoreIface (iface, _no_change, details, a)
604     = return (iface, details, a)
605
606 -- Don't output any code.
607 hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
608 hscNothing (iface, details, _)
609     = return (HscRecomp False, iface, details)
610
611 -- Generate code and return both the new ModIface and the ModDetails.
612 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
613 hscBatch (iface, details, cgguts)
614     = do hasStub <- hscCompile cgguts
615          return (HscRecomp hasStub, iface, details)
616
617 -- Here we don't need the ModIface and ModDetails anymore.
618 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
619 hscOneShot (_, _, cgguts)
620     = do hasStub <- hscCompile cgguts
621          return (HscRecomp hasStub)
622
623 -- Compile to hard-code.
624 hscCompile :: CgGuts -> Comp Bool
625 hscCompile cgguts
626     = do hsc_env <- gets compHscEnv
627          mod_summary <- gets compModSummary
628          liftIO $ do
629          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
630                      -- From now on, we just use the bits we need.
631                      cg_module   = this_mod,
632                      cg_binds    = core_binds,
633                      cg_tycons   = tycons,
634                      cg_dir_imps = dir_imps,
635                      cg_foreign  = foreign_stubs,
636                      cg_dep_pkgs = dependencies,
637                      cg_hpc_info = hpc_info } = cgguts
638              dflags = hsc_dflags hsc_env
639              location = ms_location mod_summary
640              data_tycons = filter isDataTyCon tycons
641              -- cg_tycons includes newtypes, for the benefit of External Core,
642              -- but we don't generate any code for newtypes
643
644          -------------------
645          -- PREPARE FOR CODE GENERATION
646          -- Do saturation and convert to A-normal form
647          prepd_binds <- {-# SCC "CorePrep" #-}
648                         corePrepPgm dflags core_binds data_tycons ;
649          -----------------  Convert to STG ------------------
650          (stg_binds, cost_centre_info)
651              <- {-# SCC "CoreToStg" #-}
652                 myCoreToStg dflags this_mod prepd_binds 
653          ------------------  Code generation ------------------
654          cmms <- {-# SCC "CodeGen" #-}
655                       codeGen dflags this_mod data_tycons
656                               dir_imps cost_centre_info
657                               stg_binds hpc_info
658          --- Optionally run experimental Cmm transformations ---
659          cmms <- optionallyConvertAndOrCPS dflags cmms
660                  -- ^ unless certain dflags are on, the identity function
661          ------------------  Code output -----------------------
662          rawcmms <- cmmToRawCmm cmms
663          (_stub_h_exists, stub_c_exists)
664              <- codeOutput dflags this_mod location foreign_stubs 
665                 dependencies rawcmms
666          return stub_c_exists
667
668 hscInteractive :: (ModIface, ModDetails, CgGuts)
669                -> Comp (InteractiveStatus, ModIface, ModDetails)
670 #ifdef GHCI
671 hscInteractive (iface, details, cgguts)
672     = do hsc_env <- gets compHscEnv
673          mod_summary <- gets compModSummary
674          liftIO $ do
675          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
676                      -- From now on, we just use the bits we need.
677                      cg_module   = this_mod,
678                      cg_binds    = core_binds,
679                      cg_tycons   = tycons,
680                      cg_foreign  = foreign_stubs,
681                      cg_modBreaks = mod_breaks } = cgguts
682              dflags = hsc_dflags hsc_env
683              location = ms_location mod_summary
684              data_tycons = filter isDataTyCon tycons
685              -- cg_tycons includes newtypes, for the benefit of External Core,
686              -- but we don't generate any code for newtypes
687
688          -------------------
689          -- PREPARE FOR CODE GENERATION
690          -- Do saturation and convert to A-normal form
691          prepd_binds <- {-# SCC "CorePrep" #-}
692                         corePrepPgm dflags core_binds data_tycons ;
693          -----------------  Generate byte code ------------------
694          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
695          ------------------ Create f-x-dynamic C-side stuff ---
696          (_istub_h_exists, istub_c_exists) 
697              <- outputForeignStubs dflags this_mod location foreign_stubs
698          return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)
699 #else
700 hscInteractive _ = panic "GHC not compiled with interpreter"
701 #endif
702
703 ------------------------------
704
705 hscCmmFile :: DynFlags -> FilePath -> IO Bool
706 hscCmmFile dflags filename = do
707   maybe_cmm <- parseCmmFile dflags filename
708   case maybe_cmm of
709     Nothing -> return False
710     Just cmm -> do
711         cmms <- optionallyConvertAndOrCPS dflags [cmm]
712         rawCmms <- cmmToRawCmm cmms
713         codeOutput dflags no_mod no_loc NoStubs [] rawCmms
714         return True
715   where
716         no_mod = panic "hscCmmFile: no_mod"
717         no_loc = ModLocation{ ml_hs_file  = Just filename,
718                               ml_hi_file  = panic "hscCmmFile: no hi file",
719                               ml_obj_file = panic "hscCmmFile: no obj file" }
720
721 optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
722 optionallyConvertAndOrCPS dflags cmms =
723     do   --------  Optionally convert to and from zipper ------
724        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
725                then mapM (testCmmConversion dflags) cmms
726                else return cmms
727          ---------  Optionally convert to CPS (MDA) -----------
728        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
729                   dopt Opt_RunCPSZ dflags
730                then cmmCPS dflags cmms
731                else return cmms
732        return cmms
733
734
735 testCmmConversion :: DynFlags -> Cmm -> IO Cmm
736 testCmmConversion dflags cmm =
737     do showPass dflags "CmmToCmm"
738        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
739        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
740        us <- mkSplitUniqSupply 'C'
741        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
742        let cvtm = do g <- cmmToZgraph cmm
743                      return $ cfopts g
744        let zgraph = initUs_ us cvtm
745        cps_zgraph <- protoCmmCPSZ dflags zgraph
746        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
747        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
748        showPass dflags "Convert from Z back to Cmm"
749        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
750        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
751        return cvt
752        -- return cmm -- don't use the conversion
753
754 myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
755               -> IO (Either ErrMsg (Located (HsModule RdrName)))
756 myParseModule dflags src_filename maybe_src_buf
757  =    --------------------------  Parser  ----------------
758       showPass dflags "Parser" >>
759       {-# SCC "Parser" #-} do
760
761         -- sometimes we already have the buffer in memory, perhaps
762         -- because we needed to parse the imports out of it, or get the 
763         -- module name.
764       buf <- case maybe_src_buf of
765                 Just b  -> return b
766                 Nothing -> hGetStringBuffer src_filename
767
768       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
769
770       case unP parseModule (mkPState buf loc dflags) of {
771
772         PFailed span err -> return (Left (mkPlainErrMsg span err));
773
774         POk pst rdr_module -> do {
775
776       let {ms = getMessages pst};
777       printErrorsAndWarnings dflags ms;
778       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
779       
780       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
781       
782       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
783                            (ppSourceStats False rdr_module) ;
784       
785       return (Right rdr_module)
786         -- ToDo: free the string buffer later.
787       }}
788
789
790 myCoreToStg :: DynFlags -> Module -> [CoreBind]
791             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
792                   , CollectedCCs) -- cost centre info (declared and used)
793
794 myCoreToStg dflags this_mod prepd_binds
795  = do 
796       stg_binds <- {-# SCC "Core2Stg" #-}
797              coreToStg (thisPackage dflags) prepd_binds
798
799       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
800              stg2stg dflags this_mod stg_binds
801
802       return (stg_binds2, cost_centre_info)
803 \end{code}
804
805
806 %************************************************************************
807 %*                                                                      *
808 \subsection{Compiling a do-statement}
809 %*                                                                      *
810 %************************************************************************
811
812 When the UnlinkedBCOExpr is linked you get an HValue of type
813         IO [HValue]
814 When you run it you get a list of HValues that should be 
815 the same length as the list of names; add them to the ClosureEnv.
816
817 A naked expression returns a singleton Name [it].
818
819         What you type                   The IO [HValue] that hscStmt returns
820         -------------                   ------------------------------------
821         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
822                                         bindings: [x,y,...]
823
824         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
825                                         bindings: [x,y,...]
826
827         expr (of IO type)       ==>     expr >>= \ v -> return [v]
828           [NB: result not printed]      bindings: [it]
829           
830
831         expr (of non-IO type, 
832           result showable)      ==>     let v = expr in print v >> return [v]
833                                         bindings: [it]
834
835         expr (of non-IO type, 
836           result not showable)  ==>     error
837
838 \begin{code}
839 #ifdef GHCI
840 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
841   :: HscEnv
842   -> String                     -- The statement
843   -> IO (Maybe ([Id], HValue))
844
845 hscStmt hsc_env stmt
846   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
847         ; case maybe_stmt of {
848              Nothing      -> return Nothing ;   -- Parse error
849              Just Nothing -> return Nothing ;   -- Empty line
850              Just (Just parsed_stmt) -> do {    -- The real stuff
851
852                 -- Rename and typecheck it
853           let icontext = hsc_IC hsc_env
854         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
855
856         ; case maybe_tc_result of {
857                 Nothing -> return Nothing ;
858                 Just (ids, tc_expr) -> do {
859
860                 -- Desugar it
861         ; let rdr_env  = ic_rn_gbl_env icontext
862               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
863         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
864         
865         ; case mb_ds_expr of {
866                 Nothing -> return Nothing ;
867                 Just ds_expr -> do {
868
869                 -- Then desugar, code gen, and link it
870         ; let src_span = srcLocSpan interactiveSrcLoc
871         ; hval <- compileExpr hsc_env src_span ds_expr
872
873         ; return (Just (ids, hval))
874         }}}}}}}
875
876 hscTcExpr       -- Typecheck an expression (but don't run it)
877   :: HscEnv
878   -> String                     -- The expression
879   -> IO (Maybe Type)
880
881 hscTcExpr hsc_env expr
882   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
883         ; let icontext = hsc_IC hsc_env
884         ; case maybe_stmt of {
885              Nothing      -> return Nothing ;   -- Parse error
886              Just (Just (L _ (ExprStmt expr _ _)))
887                         -> tcRnExpr hsc_env icontext expr ;
888              Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
889                                 return Nothing } ;
890              } }
891
892 hscKcType       -- Find the kind of a type
893   :: HscEnv
894   -> String                     -- The type
895   -> IO (Maybe Kind)
896
897 hscKcType hsc_env str
898   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
899         ; let icontext = hsc_IC hsc_env
900         ; case maybe_type of {
901              Just ty -> tcRnType hsc_env icontext ty ;
902              Nothing -> return Nothing } }
903 #endif
904 \end{code}
905
906 \begin{code}
907 #ifdef GHCI
908 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
909 hscParseStmt = hscParseThing parseStmt
910
911 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
912 hscParseType = hscParseThing parseType
913 #endif
914
915 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
916 hscParseIdentifier = hscParseThing parseIdentifier
917
918 hscParseThing :: Outputable thing
919               => Lexer.P thing
920               -> DynFlags -> String
921               -> IO (Maybe thing)
922         -- Nothing => Parse error (message already printed)
923         -- Just x  => success
924 hscParseThing parser dflags str
925  = showPass dflags "Parser" >>
926       {-# SCC "Parser" #-} do
927
928       buf <- stringToStringBuffer str
929
930       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
931
932       case unP parser (mkPState buf loc dflags) of {
933
934         PFailed span err -> do { printError span err;
935                                  return Nothing };
936
937         POk pst thing -> do {
938
939       let {ms = getMessages pst};
940       printErrorsAndWarnings dflags ms;
941       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
942
943       --ToDo: can't free the string buffer until we've finished this
944       -- compilation sweep and all the identifiers have gone away.
945       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
946       return (Just thing)
947       }}
948 \end{code}
949
950 %************************************************************************
951 %*                                                                      *
952         Desugar, simplify, convert to bytecode, and link an expression
953 %*                                                                      *
954 %************************************************************************
955
956 \begin{code}
957 #ifdef GHCI
958 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
959
960 compileExpr hsc_env srcspan ds_expr
961   = do  { let { dflags  = hsc_dflags hsc_env ;
962                 lint_on = dopt Opt_DoCoreLinting dflags }
963               
964                 -- Flatten it
965         ; flat_expr <- flattenExpr hsc_env ds_expr
966
967                 -- Simplify it
968         ; simpl_expr <- simplifyExpr dflags flat_expr
969
970                 -- Tidy it (temporary, until coreSat does cloning)
971         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
972
973                 -- Prepare for codegen
974         ; prepd_expr <- corePrepExpr dflags tidy_expr
975
976                 -- Lint if necessary
977                 -- ToDo: improve SrcLoc
978         ; if lint_on then 
979                 let ictxt = hsc_IC hsc_env
980                     tyvars = varSetElems (ic_tyvars ictxt)
981                 in
982                 case lintUnfolding noSrcLoc tyvars prepd_expr of
983                    Just err -> pprPanic "compileExpr" err
984                    Nothing  -> return ()
985           else
986                 return ()
987
988                 -- Convert to BCOs
989         ; bcos <- coreExprToBCOs dflags prepd_expr
990
991                 -- link it
992         ; hval <- linkExpr hsc_env srcspan bcos
993
994         ; return hval
995      }
996 #endif
997 \end{code}
998
999
1000 %************************************************************************
1001 %*                                                                      *
1002         Statistics on reading interfaces
1003 %*                                                                      *
1004 %************************************************************************
1005
1006 \begin{code}
1007 dumpIfaceStats :: HscEnv -> IO ()
1008 dumpIfaceStats hsc_env
1009   = do  { eps <- readIORef (hsc_EPS hsc_env)
1010         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1011                     "Interface statistics"
1012                     (ifaceStats eps) }
1013   where
1014     dflags = hsc_dflags hsc_env
1015     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1016     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1017 \end{code}
1018
1019 %************************************************************************
1020 %*                                                                      *
1021         Progress Messages: Module i of n
1022 %*                                                                      *
1023 %************************************************************************
1024
1025 \begin{code}
1026 showModuleIndex :: Maybe (Int, Int) -> String
1027 showModuleIndex Nothing = ""
1028 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1029     where
1030         n_str = show n
1031         i_str = show i
1032         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1033 \end{code}
1034