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