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