Implemented and fixed bugs in CmmInfo handling
[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 CmmInfo
80 import CodeOutput       ( codeOutput )
81 import NameEnv          ( emptyNameEnv )
82
83 import DynFlags
84 import ErrUtils
85 import UniqSupply       ( mkSplitUniqSupply )
86
87 import Outputable
88 import HscStats         ( ppSourceStats )
89 import HscTypes
90 import MkExternalCore   ( emitExternalCore )
91 import ParserCore
92 import ParserCoreUtils
93 import FastString
94 import UniqFM           ( emptyUFM )
95 import Bag              ( unitBag )
96
97 import Control.Monad
98 import System.Exit
99 import System.IO
100 import Data.IORef
101 \end{code}
102
103
104 %************************************************************************
105 %*                                                                      *
106                 Initialisation
107 %*                                                                      *
108 %************************************************************************
109
110 \begin{code}
111 newHscEnv :: DynFlags -> IO HscEnv
112 newHscEnv dflags
113   = do  { eps_var <- newIORef initExternalPackageState
114         ; us      <- mkSplitUniqSupply 'r'
115         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
116         ; fc_var  <- newIORef emptyUFM
117         ; mlc_var  <- newIORef emptyModuleEnv
118         ; return (HscEnv { hsc_dflags = dflags,
119                            hsc_targets = [],
120                            hsc_mod_graph = [],
121                            hsc_IC     = emptyInteractiveContext,
122                            hsc_HPT    = emptyHomePackageTable,
123                            hsc_EPS    = eps_var,
124                            hsc_NC     = nc_var,
125                            hsc_FC     = fc_var,
126                            hsc_MLC    = mlc_var,
127                            hsc_global_rdr_env = emptyGlobalRdrEnv,
128                            hsc_global_type_env = emptyNameEnv } ) }
129                         
130
131 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
132                         -- where templateHaskellNames are defined
133 knownKeyNames = map getName wiredInThings 
134               ++ basicKnownKeyNames
135 #ifdef GHCI
136               ++ templateHaskellNames
137 #endif
138 \end{code}
139
140
141 %************************************************************************
142 %*                                                                      *
143                 The main compiler pipeline
144 %*                                                                      *
145 %************************************************************************
146
147                    --------------------------------
148                         The compilation proper
149                    --------------------------------
150
151
152 It's the task of the compilation proper to compile Haskell, hs-boot and
153 core files to either byte-code, hard-code (C, asm, Java, ect) or to
154 nothing at all (the module is still parsed and type-checked. This
155 feature is mostly used by IDE's and the likes).
156 Compilation can happen in either 'one-shot', 'batch', 'nothing',
157 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
158 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
159 targets byte-code.
160 The modes are kept separate because of their different types and meanings.
161 In 'one-shot' mode, we're only compiling a single file and can therefore
162 discard the new ModIface and ModDetails. This is also the reason it only
163 targets hard-code; compiling to byte-code or nothing doesn't make sense
164 when we discard the result.
165 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
166 and ModDetails. 'Batch' mode doesn't target byte-code since that require
167 us to return the newly compiled byte-code.
168 'Nothing' mode has exactly the same type as 'batch' mode but they're still
169 kept separate. This is because compiling to nothing is fairly special: We
170 don't output any interface files, we don't run the simplifier and we don't
171 generate any code.
172 'Interactive' mode is similar to 'batch' mode except that we return the
173 compiled byte-code together with the ModIface and ModDetails.
174
175 Trying to compile a hs-boot file to byte-code will result in a run-time
176 error. This is the only thing that isn't caught by the type-system.
177
178 \begin{code}
179
180 data HscChecked
181     = HscChecked
182         -- parsed
183         (Located (HsModule RdrName))
184         -- renamed
185         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
186                 Maybe (HsDoc Name), HaddockModInfo Name))
187         -- typechecked
188         (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
189         -- desugared
190         (Maybe [CoreBind])
191
192 -- Status of a compilation to hard-code or nothing.
193 data HscStatus
194     = HscNoRecomp
195     | HscRecomp  Bool -- Has stub files.
196                       -- This is a hack. We can't compile C files here
197                       -- since it's done in DriverPipeline. For now we
198                       -- just return True if we want the caller to compile
199                       -- them for us.
200
201 -- Status of a compilation to byte-code.
202 data InteractiveStatus
203     = InteractiveNoRecomp
204     | InteractiveRecomp Bool     -- Same as HscStatus
205                         CompiledByteCode
206
207
208 -- I want Control.Monad.State! --Lemmih 03/07/2006
209 newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)}
210
211 instance Monad Comp where
212     g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s'
213     return a = Comp $ \s -> return (a,s)
214     fail = error
215
216 evalComp :: Comp a -> CompState -> IO a
217 evalComp comp st = do (val,_st') <- runComp comp st
218                       return val
219
220 data CompState
221     = CompState
222     { compHscEnv     :: HscEnv
223     , compModSummary :: ModSummary
224     , compOldIface   :: Maybe ModIface
225     }
226
227 get :: Comp CompState
228 get = Comp $ \s -> return (s,s)
229
230 modify :: (CompState -> CompState) -> Comp ()
231 modify f = Comp $ \s -> return ((), f s)
232
233 gets :: (CompState -> a) -> Comp a
234 gets getter = do st <- get
235                  return (getter st)
236
237 liftIO :: IO a -> Comp a
238 liftIO ioA = Comp $ \s -> do a <- ioA
239                              return (a,s)
240
241 type NoRecomp result = ModIface -> Comp result
242 type FrontEnd core = Comp (Maybe core)
243
244 -- FIXME: The old interface and module index are only using in 'batch' and
245 --        'interactive' mode. They should be removed from 'oneshot' mode.
246 type Compiler result =  HscEnv
247                      -> ModSummary
248                      -> Bool                -- True <=> source unchanged
249                      -> Maybe ModIface      -- Old interface, if available
250                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
251                      -> IO (Maybe result)
252
253
254 -- This functions checks if recompilation is necessary and
255 -- then combines the FrontEnd and BackEnd to a working compiler.
256 hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
257               -> (Maybe (Int,Int) -> Bool -> Comp ())
258               -> FrontEnd core
259               -> (core -> Comp result)   -- Backend.
260               -> Compiler result
261 hscMkCompiler norecomp messenger frontend backend
262               hsc_env mod_summary source_unchanged
263               mbOldIface mbModIndex
264     = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
265       do (recomp_reqd, mbCheckedIface)
266              <- {-# SCC "checkOldIface" #-}
267                 liftIO $ checkOldIface hsc_env mod_summary
268                               source_unchanged mbOldIface
269          -- save the interface that comes back from checkOldIface.
270          -- In one-shot mode we don't have the old iface until this
271          -- point, when checkOldIface reads it from the disk.
272          modify (\s -> s{ compOldIface = mbCheckedIface })
273          case mbCheckedIface of 
274            Just iface | not recomp_reqd
275                -> do messenger mbModIndex False
276                      result <- norecomp iface
277                      return (Just result)
278            _otherwise
279                -> do messenger mbModIndex True
280                      mbCore <- frontend
281                      case mbCore of
282                        Nothing
283                            -> return Nothing
284                        Just core
285                            -> do result <- backend core
286                                  return (Just result)
287
288 --------------------------------------------------------------
289 -- Compilers
290 --------------------------------------------------------------
291
292 --        1         2         3         4         5         6         7         8          9
293 -- Compile Haskell, boot and extCore in OneShot mode.
294 hscCompileOneShot :: Compiler HscStatus
295 hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False))
296
297 -- Compile Haskell, boot and extCore in batch mode.
298 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
299 hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing
300
301 -- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch.
302 hscCompileHardCode :: NoRecomp result                                  -- No recomp necessary
303                    -> (Maybe (Int,Int) -> Bool -> Comp ())             -- Message callback
304                    -> ((ModIface, ModDetails, CgGuts) -> Comp result)  -- Compile normal file
305                    -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file
306                    -> Compiler result
307 hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary =
308     compiler hsc_env mod_summary
309     where mkComp = hscMkCompiler norecomp msg
310           -- How to compile nonBoot files.
311           nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
312                             hscWriteIface >>= compNormal
313           -- How to compile boot files.
314           bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot
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) >= 2
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          ------------------  Convert to CPS --------------------
609          --continuationC <- cmmCPS dflags abstractC
610          continuationC <- cmmToRawCmm abstractC
611          ------------------  Code output -----------------------
612          (stub_h_exists,stub_c_exists)
613              <- codeOutput dflags this_mod location foreign_stubs 
614                 dependencies continuationC
615          return stub_c_exists
616
617 hscConst :: b -> a -> Comp b
618 hscConst b a = return b
619
620 hscInteractive :: (ModIface, ModDetails, CgGuts)
621                -> Comp (InteractiveStatus, ModIface, ModDetails)
622 hscInteractive (iface, details, cgguts)
623 #ifdef GHCI
624     = do hsc_env <- gets compHscEnv
625          mod_summary <- gets compModSummary
626          liftIO $ do
627          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
628                      -- From now on, we just use the bits we need.
629                      cg_module   = this_mod,
630                      cg_binds    = core_binds,
631                      cg_tycons   = tycons,
632                      cg_foreign  = foreign_stubs } = cgguts
633              dflags = hsc_dflags hsc_env
634              location = ms_location mod_summary
635              data_tycons = filter isDataTyCon tycons
636              -- cg_tycons includes newtypes, for the benefit of External Core,
637              -- but we don't generate any code for newtypes
638
639          -------------------
640          -- PREPARE FOR CODE GENERATION
641          -- Do saturation and convert to A-normal form
642          prepd_binds <- {-# SCC "CorePrep" #-}
643                         corePrepPgm dflags core_binds data_tycons ;
644          -----------------  Generate byte code ------------------
645          comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
646          ------------------ Create f-x-dynamic C-side stuff ---
647          (istub_h_exists, istub_c_exists) 
648              <- outputForeignStubs dflags this_mod location foreign_stubs
649          return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
650 #else
651     = panic "GHC not compiled with interpreter"
652 #endif
653
654 ------------------------------
655
656 hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
657 hscFileCheck hsc_env mod_summary compileToCore = do {
658             -------------------
659             -- PARSE
660             -------------------
661         ; let dflags    = hsc_dflags hsc_env
662               hspp_file = ms_hspp_file mod_summary
663               hspp_buf  = ms_hspp_buf  mod_summary
664
665         ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
666
667         ; case maybe_parsed of {
668              Left err -> do { printBagOfErrors dflags (unitBag err)
669                             ; return Nothing } ;
670              Right rdr_module -> do {
671
672             -------------------
673             -- RENAME and TYPECHECK
674             -------------------
675           (tc_msgs, maybe_tc_result) 
676                 <- _scc_ "Typecheck-Rename" 
677                    tcRnModule hsc_env (ms_hsc_src mod_summary) 
678                         True{-save renamed syntax-}
679                         rdr_module
680
681         ; printErrorsAndWarnings dflags tc_msgs
682         ; case maybe_tc_result of {
683              Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
684              Just tc_result -> do
685                 let type_env = tcg_type_env tc_result
686                     md = ModDetails { 
687                                 md_types     = type_env,
688                                 md_exports   = tcg_exports   tc_result,
689                                 md_insts     = tcg_insts     tc_result,
690                                 md_fam_insts = tcg_fam_insts tc_result,
691                                 md_modBreaks = emptyModBreaks,      
692                                 md_rules     = [panic "no rules"],
693                                    -- Rules are CoreRules, not the
694                                    -- RuleDecls we get out of the typechecker
695                                 md_vect_info = 
696                                   panic "HscMain.hscFileCheck: no VectInfo"
697                                    -- VectInfo is added by the Core 
698                                    -- vectorisation pass
699                           }
700                     rnInfo = do decl <- tcg_rn_decls tc_result
701                                 imports <- tcg_rn_imports tc_result
702                                 let exports = tcg_rn_exports tc_result
703                                 let doc = tcg_doc tc_result
704                                     hmi = tcg_hmi tc_result
705                                 return (decl,imports,exports,doc,hmi)
706                 maybeModGuts <- 
707                  if compileToCore then
708                    deSugar hsc_env (ms_location mod_summary) tc_result
709                  else
710                    return Nothing
711                 return (Just (HscChecked rdr_module 
712                                    rnInfo
713                                    (Just (tcg_binds tc_result,
714                                           tcg_rdr_env tc_result,
715                                           md))
716                                    (fmap mg_binds maybeModGuts)))
717         }}}}
718
719
720 hscCmmFile :: DynFlags -> FilePath -> IO Bool
721 hscCmmFile dflags filename = do
722   maybe_cmm <- parseCmmFile dflags filename
723   case maybe_cmm of
724     Nothing -> return False
725     Just cmm -> do
726         --continuationC <- cmmCPS dflags [cmm]
727         continuationC <- cmmToRawCmm [cmm]
728         codeOutput dflags no_mod no_loc NoStubs [] continuationC
729         return True
730   where
731         no_mod = panic "hscCmmFile: no_mod"
732         no_loc = ModLocation{ ml_hs_file  = Just filename,
733                               ml_hi_file  = panic "hscCmmFile: no hi file",
734                               ml_obj_file = panic "hscCmmFile: no obj file" }
735
736
737 myParseModule dflags src_filename maybe_src_buf
738  =    --------------------------  Parser  ----------------
739       showPass dflags "Parser" >>
740       {-# SCC "Parser" #-} do
741
742         -- sometimes we already have the buffer in memory, perhaps
743         -- because we needed to parse the imports out of it, or get the 
744         -- module name.
745       buf <- case maybe_src_buf of
746                 Just b  -> return b
747                 Nothing -> hGetStringBuffer src_filename
748
749       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
750
751       case unP parseModule (mkPState buf loc dflags) of {
752
753         PFailed span err -> return (Left (mkPlainErrMsg span err));
754
755         POk pst rdr_module -> do {
756
757       let {ms = getMessages pst};
758       printErrorsAndWarnings dflags ms;
759       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
760       
761       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
762       
763       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
764                            (ppSourceStats False rdr_module) ;
765       
766       return (Right rdr_module)
767         -- ToDo: free the string buffer later.
768       }}
769
770
771 myCoreToStg dflags this_mod prepd_binds
772  = do 
773       stg_binds <- {-# SCC "Core2Stg" #-}
774              coreToStg (thisPackage dflags) prepd_binds
775
776       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
777              stg2stg dflags this_mod stg_binds
778
779       return (stg_binds2, cost_centre_info)
780 \end{code}
781
782
783 %************************************************************************
784 %*                                                                      *
785 \subsection{Compiling a do-statement}
786 %*                                                                      *
787 %************************************************************************
788
789 When the UnlinkedBCOExpr is linked you get an HValue of type
790         IO [HValue]
791 When you run it you get a list of HValues that should be 
792 the same length as the list of names; add them to the ClosureEnv.
793
794 A naked expression returns a singleton Name [it].
795
796         What you type                   The IO [HValue] that hscStmt returns
797         -------------                   ------------------------------------
798         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
799                                         bindings: [x,y,...]
800
801         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
802                                         bindings: [x,y,...]
803
804         expr (of IO type)       ==>     expr >>= \ v -> return [v]
805           [NB: result not printed]      bindings: [it]
806           
807
808         expr (of non-IO type, 
809           result showable)      ==>     let v = expr in print v >> return [v]
810                                         bindings: [it]
811
812         expr (of non-IO type, 
813           result not showable)  ==>     error
814
815 \begin{code}
816 #ifdef GHCI
817 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
818   :: HscEnv
819   -> String                     -- The statement
820   -> IO (Maybe ([Id], HValue))
821
822 hscStmt hsc_env stmt
823   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
824         ; case maybe_stmt of {
825              Nothing      -> return Nothing ;   -- Parse error
826              Just Nothing -> return Nothing ;   -- Empty line
827              Just (Just parsed_stmt) -> do {    -- The real stuff
828
829                 -- Rename and typecheck it
830           let icontext = hsc_IC hsc_env
831         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
832
833         ; case maybe_tc_result of {
834                 Nothing -> return Nothing ;
835                 Just (ids, tc_expr) -> do {
836
837                 -- Desugar it
838         ; let rdr_env  = ic_rn_gbl_env icontext
839               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
840         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
841         
842         ; case mb_ds_expr of {
843                 Nothing -> return Nothing ;
844                 Just ds_expr -> do {
845
846                 -- Then desugar, code gen, and link it
847         ; let src_span = srcLocSpan interactiveSrcLoc
848         ; hval <- compileExpr hsc_env src_span ds_expr
849
850         ; return (Just (ids, hval))
851         }}}}}}}
852
853 hscTcExpr       -- Typecheck an expression (but don't run it)
854   :: HscEnv
855   -> String                     -- The expression
856   -> IO (Maybe Type)
857
858 hscTcExpr hsc_env expr
859   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
860         ; let icontext = hsc_IC hsc_env
861         ; case maybe_stmt of {
862              Nothing      -> return Nothing ;   -- Parse error
863              Just (Just (L _ (ExprStmt expr _ _)))
864                         -> tcRnExpr hsc_env icontext expr ;
865              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
866                                 return Nothing } ;
867              } }
868
869 hscKcType       -- Find the kind of a type
870   :: HscEnv
871   -> String                     -- The type
872   -> IO (Maybe Kind)
873
874 hscKcType hsc_env str
875   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
876         ; let icontext = hsc_IC hsc_env
877         ; case maybe_type of {
878              Just ty -> tcRnType hsc_env icontext ty ;
879              Nothing -> return Nothing } }
880 #endif
881 \end{code}
882
883 \begin{code}
884 #ifdef GHCI
885 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
886 hscParseStmt = hscParseThing parseStmt
887
888 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
889 hscParseType = hscParseThing parseType
890 #endif
891
892 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
893 hscParseIdentifier = hscParseThing parseIdentifier
894
895 hscParseThing :: Outputable thing
896               => Lexer.P thing
897               -> DynFlags -> String
898               -> IO (Maybe thing)
899         -- Nothing => Parse error (message already printed)
900         -- Just x  => success
901 hscParseThing parser dflags str
902  = showPass dflags "Parser" >>
903       {-# SCC "Parser" #-} do
904
905       buf <- stringToStringBuffer str
906
907       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
908
909       case unP parser (mkPState buf loc dflags) of {
910
911         PFailed span err -> do { printError span err;
912                                  return Nothing };
913
914         POk pst thing -> do {
915
916       let {ms = getMessages pst};
917       printErrorsAndWarnings dflags ms;
918       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
919
920       --ToDo: can't free the string buffer until we've finished this
921       -- compilation sweep and all the identifiers have gone away.
922       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
923       return (Just thing)
924       }}
925 \end{code}
926
927 %************************************************************************
928 %*                                                                      *
929         Desugar, simplify, convert to bytecode, and link an expression
930 %*                                                                      *
931 %************************************************************************
932
933 \begin{code}
934 #ifdef GHCI
935 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
936
937 compileExpr hsc_env srcspan ds_expr
938   = do  { let { dflags  = hsc_dflags hsc_env ;
939                 lint_on = dopt Opt_DoCoreLinting dflags }
940               
941                 -- Flatten it
942         ; flat_expr <- flattenExpr hsc_env ds_expr
943
944                 -- Simplify it
945         ; simpl_expr <- simplifyExpr dflags flat_expr
946
947                 -- Tidy it (temporary, until coreSat does cloning)
948         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
949
950                 -- Prepare for codegen
951         ; prepd_expr <- corePrepExpr dflags tidy_expr
952
953                 -- Lint if necessary
954                 -- ToDo: improve SrcLoc
955         ; if lint_on then 
956                 let ictxt = hsc_IC hsc_env
957                     tyvars = varSetElems (ic_tyvars ictxt)
958                 in
959                 case lintUnfolding noSrcLoc tyvars prepd_expr of
960                    Just err -> pprPanic "compileExpr" err
961                    Nothing  -> return ()
962           else
963                 return ()
964
965                 -- Convert to BCOs
966         ; bcos <- coreExprToBCOs dflags prepd_expr
967
968                 -- link it
969         ; hval <- linkExpr hsc_env srcspan bcos
970
971         ; return hval
972      }
973 #endif
974 \end{code}
975
976
977 %************************************************************************
978 %*                                                                      *
979         Statistics on reading interfaces
980 %*                                                                      *
981 %************************************************************************
982
983 \begin{code}
984 dumpIfaceStats :: HscEnv -> IO ()
985 dumpIfaceStats hsc_env
986   = do  { eps <- readIORef (hsc_EPS hsc_env)
987         ; dumpIfSet (dump_if_trace || dump_rn_stats)
988                     "Interface statistics"
989                     (ifaceStats eps) }
990   where
991     dflags = hsc_dflags hsc_env
992     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
993     dump_if_trace = dopt Opt_D_dump_if_trace dflags
994 \end{code}
995
996 %************************************************************************
997 %*                                                                      *
998         Progress Messages: Module i of n
999 %*                                                                      *
1000 %************************************************************************
1001
1002 \begin{code}
1003 showModuleIndex Nothing = ""
1004 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1005     where
1006         n_str = show n
1007         i_str = show i
1008         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1009 \end{code}
1010