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