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