266395d0b14c61a8f5e78c4b53474ddec0fababf
[ghc.git] / compiler / main / HscMain.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
3 %
4 \begin{code}
5 -- | Main API for compiling plain Haskell source code.
6 --
7 -- This module implements compilation of a Haskell source.  It is
8 -- /not/ concerned with preprocessing of source files; this is handled
9 -- in "DriverPipeline".
10 --
11 -- There are various entry points depending on what mode we're in:
12 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
13 -- "interactive" mode (GHCi).  There are also entry points for
14 -- individual passes: parsing, typechecking/renaming, desugaring, and
15 -- simplification.
16 --
17 -- All the functions here take an 'HscEnv' as a parameter, but none of
18 -- them return a new one: 'HscEnv' is treated as an immutable value
19 -- from here on in (although it has mutable components, for the
20 -- caches).
21 --
22 -- Warning messages are dealt with consistently throughout this API:
23 -- during compilation warnings are collected, and before any function
24 -- in @HscMain@ returns, the warnings are either printed, or turned
25 -- into a real compialtion error if the @-Werror@ flag is enabled.
26 --
27 module HscMain
28     ( 
29     -- * Making an HscEnv
30       newHscEnv
31
32     -- * Compiling complete source files
33     , Compiler
34     , HscStatus' (..)
35     , InteractiveStatus, HscStatus
36     , hscCompileOneShot
37     , hscCompileBatch
38     , hscCompileNothing
39     , hscCompileInteractive
40     , hscCompileCmmFile
41     , hscCompileCore
42
43     -- * Running passes separately
44     , hscParse
45     , hscTypecheckRename
46     , hscDesugar
47     , makeSimpleIface
48     , makeSimpleDetails
49     , hscSimplify -- ToDo, shouldn't really export this
50
51     -- ** Backends
52     , hscOneShotBackendOnly
53     , hscBatchBackendOnly
54     , hscNothingBackendOnly
55     , hscInteractiveBackendOnly
56
57     -- * Support for interactive evaluation
58     , hscParseIdentifier
59     , hscTcRcLookupName
60     , hscTcRnGetInfo
61 #ifdef GHCI
62     , hscRnImportDecls
63     , hscGetModuleExports
64     , hscTcRnLookupRdrName
65     , hscStmt, hscStmtWithLocation
66     , hscTcExpr, hscImport, hscKcType
67     , hscCompileCoreExpr
68 #endif
69
70     ) where
71
72 #ifdef GHCI
73 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
74 import Linker           ( HValue, linkExpr )
75 import CoreTidy         ( tidyExpr )
76 import Type             ( Type )
77 import TcType           ( tyVarsOfTypes )
78 import PrelNames        ( iNTERACTIVE )
79 import {- Kind parts of -} Type         ( Kind )
80 import Id               ( idType )
81 import CoreLint         ( lintUnfolding )
82 import DsMeta           ( templateHaskellNames )
83 import VarSet
84 import VarEnv           ( emptyTidyEnv )
85 import Panic
86 #endif
87
88 import Id               ( Id )
89 import Module
90 import Packages
91 import RdrName
92 import HsSyn
93 import CoreSyn
94 import StringBuffer
95 import Parser
96 import Lexer hiding (getDynFlags)
97 import SrcLoc
98 import TcRnDriver
99 import TcIface          ( typecheckIface )
100 import TcRnMonad
101 import IfaceEnv         ( initNameCache )
102 import LoadIface        ( ifaceStats, initExternalPackageState )
103 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
104 import MkIface
105 import Desugar
106 import SimplCore
107 import TidyPgm
108 import CorePrep
109 import CoreToStg        ( coreToStg )
110 import qualified StgCmm ( codeGen )
111 import StgSyn
112 import CostCentre
113 import ProfInit
114 import TyCon            ( TyCon, isDataTyCon )
115 import Name             ( Name, NamedThing(..) )
116 import SimplStg         ( stg2stg )
117 import CodeGen          ( codeGen )
118 import OldCmm           ( Cmm )
119 import PprCmm           ( pprCmms )
120 import CmmParse         ( parseCmmFile )
121 import CmmBuildInfoTables
122 import CmmPipeline
123 import CmmInfo
124 import OptimizationFuel ( initOptFuelState )
125 import CmmCvt
126 import CmmContFlowOpt   ( runCmmContFlowOpts )
127 import CodeOutput
128 import NameEnv          ( emptyNameEnv )
129 import NameSet          ( emptyNameSet )
130 import InstEnv
131 import FamInstEnv       ( emptyFamInstEnv )
132 import Fingerprint      ( Fingerprint )
133
134 import DynFlags
135 import ErrUtils
136 import UniqSupply       ( mkSplitUniqSupply )
137
138 import Outputable
139 import HscStats         ( ppSourceStats )
140 import HscTypes
141 import MkExternalCore   ( emitExternalCore )
142 import FastString
143 import UniqFM           ( emptyUFM )
144 import UniqSupply       ( initUs_ )
145 import Bag
146 import Exception
147
148 import Control.Monad
149 import Data.Maybe       ( catMaybes )
150 import Data.IORef
151 \end{code}
152 #include "HsVersions.h"
153
154
155 %************************************************************************
156 %*                                                                      *
157                 Initialisation
158 %*                                                                      *
159 %************************************************************************
160
161 \begin{code}
162 newHscEnv :: DynFlags -> IO HscEnv
163 newHscEnv dflags
164   = do  { eps_var <- newIORef initExternalPackageState
165         ; us      <- mkSplitUniqSupply 'r'
166         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
167         ; fc_var  <- newIORef emptyUFM
168         ; mlc_var <- newIORef emptyModuleEnv
169         ; optFuel <- initOptFuelState
170         ; return (HscEnv { hsc_dflags = dflags,
171                            hsc_targets = [],
172                            hsc_mod_graph = [],
173                            hsc_IC      = emptyInteractiveContext,
174                            hsc_HPT     = emptyHomePackageTable,
175                            hsc_EPS     = eps_var,
176                            hsc_NC      = nc_var,
177                            hsc_FC      = fc_var,
178                            hsc_MLC     = mlc_var,
179                            hsc_OptFuel = optFuel,
180                            hsc_type_env_var = Nothing } ) }
181
182
183 knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
184                              -- where templateHaskellNames are defined
185 knownKeyNames
186   = map getName wiredInThings 
187     ++ basicKnownKeyNames
188 #ifdef GHCI
189     ++ templateHaskellNames
190 #endif
191
192 -- -----------------------------------------------------------------------------
193 -- The Hsc monad: collecting warnings
194
195 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
196
197 instance Monad Hsc where
198   return a = Hsc $ \_ w -> return (a, w)
199   Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
200                                  case k a of
201                                     Hsc k' -> k' e w1
202
203 instance MonadIO Hsc where
204   liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
205
206 runHsc :: HscEnv -> Hsc a -> IO a
207 runHsc hsc_env (Hsc hsc) = do
208   (a, w) <- hsc hsc_env emptyBag
209   printOrThrowWarnings (hsc_dflags hsc_env) w
210   return a
211
212 getWarnings :: Hsc WarningMessages
213 getWarnings = Hsc $ \_ w -> return (w, w)
214
215 clearWarnings :: Hsc ()
216 clearWarnings = Hsc $ \_ _w -> return ((), emptyBag)
217
218 logWarnings :: WarningMessages -> Hsc ()
219 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
220
221 getHscEnv :: Hsc HscEnv
222 getHscEnv = Hsc $ \e w -> return (e, w)
223
224 getDynFlags :: Hsc DynFlags
225 getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
226
227 handleWarnings :: Hsc ()
228 handleWarnings = do
229   dflags <- getDynFlags
230   w <- getWarnings
231   liftIO $ printOrThrowWarnings dflags w
232   clearWarnings
233
234 -- | log warning in the monad, and if there are errors then
235 -- throw a SourceError exception.
236 logWarningsReportErrors :: Messages -> Hsc ()
237 logWarningsReportErrors (warns,errs) = do
238   logWarnings warns
239   when (not (isEmptyBag errs)) $ do
240     liftIO $ throwIO $ mkSrcErr errs
241
242 -- | Deal with errors and warnings returned by a compilation step
243 --
244 -- In order to reduce dependencies to other parts of the compiler, functions
245 -- outside the "main" parts of GHC return warnings and errors as a parameter
246 -- and signal success via by wrapping the result in a 'Maybe' type.  This
247 -- function logs the returned warnings and propagates errors as exceptions
248 -- (of type 'SourceError').
249 --
250 -- This function assumes the following invariants:
251 --
252 --  1. If the second result indicates success (is of the form 'Just x'),
253 --     there must be no error messages in the first result.
254 --
255 --  2. If there are no error messages, but the second result indicates failure
256 --     there should be warnings in the first result.  That is, if the action
257 --     failed, it must have been due to the warnings (i.e., @-Werror@).
258 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
259 ioMsgMaybe ioA = do
260   ((warns,errs), mb_r) <- liftIO $ ioA
261   logWarnings warns
262   case mb_r of
263     Nothing -> liftIO $ throwIO (mkSrcErr errs)
264     Just r  -> ASSERT( isEmptyBag errs ) return r
265
266 -- | like ioMsgMaybe, except that we ignore error messages and return
267 -- 'Nothing' instead.
268 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
269 ioMsgMaybe' ioA = do
270   ((warns,_errs), mb_r) <- liftIO $ ioA
271   logWarnings warns
272   return mb_r
273
274 -- -----------------------------------------------------------------------------
275 -- | Lookup things in the compiler's environment
276
277 #ifdef GHCI
278 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
279 hscTcRnLookupRdrName hsc_env rdr_name = 
280   runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
281 #endif
282
283 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
284 hscTcRcLookupName hsc_env name = 
285   runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name
286     -- ignore errors: the only error we're likely to get is
287     -- "name not found", and the Maybe in the return type
288     -- is used to indicate that.
289
290 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
291 hscTcRnGetInfo hsc_env name =
292   runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
293
294 #ifdef GHCI
295 hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
296 hscGetModuleExports hsc_env mdl =
297   runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
298
299 -- -----------------------------------------------------------------------------
300 -- | Rename some import declarations
301
302 hscRnImportDecls
303         :: HscEnv
304         -> Module
305         -> [LImportDecl RdrName]
306         -> IO GlobalRdrEnv
307
308 -- It is important that we use tcRnImports instead of calling rnImports directly
309 -- because tcRnImports will force-load any orphan modules necessary, making extra
310 -- instances/family instances visible (GHC #4832)
311 hscRnImportDecls hsc_env this_mod import_decls
312   = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
313           fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls
314
315 #endif
316
317 -- -----------------------------------------------------------------------------
318 -- | parse a file, returning the abstract syntax
319
320 hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
321 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
322
323 -- internal version, that doesn't fail due to -Werror
324 hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
325 hscParse' mod_summary
326  = do
327    dflags <- getDynFlags
328    let 
329        src_filename  = ms_hspp_file mod_summary
330        maybe_src_buf = ms_hspp_buf  mod_summary
331
332    --------------------------  Parser  ----------------
333    liftIO $ showPass dflags "Parser"
334    {-# SCC "Parser" #-} do
335
336         -- sometimes we already have the buffer in memory, perhaps
337         -- because we needed to parse the imports out of it, or get the
338         -- module name.
339    buf <- case maybe_src_buf of
340             Just b  -> return b
341             Nothing -> liftIO $ hGetStringBuffer src_filename
342
343    let loc  = mkRealSrcLoc (mkFastString src_filename) 1 1
344
345    case unP parseModule (mkPState dflags buf loc) of
346      PFailed span err ->
347          liftIO $ throwOneError (mkPlainErrMsg span err)
348
349      POk pst rdr_module -> do
350          logWarningsReportErrors (getMessages pst)
351          liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
352                                 ppr rdr_module
353          liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
354                                 ppSourceStats False rdr_module
355          return rdr_module
356           -- ToDo: free the string buffer later.
357
358 -- XXX: should this really be a Maybe X?  Check under which circumstances this
359 -- can become a Nothing and decide whether this should instead throw an
360 -- exception/signal an error.
361 type RenamedStuff = 
362         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
363                 Maybe LHsDocString))
364
365 -- | Rename and typecheck a module, additionally returning the renamed syntax
366 hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
367                    -> IO (TcGblEnv, RenamedStuff)
368 hscTypecheckRename hsc_env mod_summary rdr_module
369   = runHsc hsc_env $ do
370       tc_result
371           <- {-# SCC "Typecheck-Rename" #-}
372               ioMsgMaybe $ 
373                   tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
374
375       let -- This 'do' is in the Maybe monad!
376           rn_info = do decl <- tcg_rn_decls tc_result
377                        let imports = tcg_rn_imports tc_result
378                            exports = tcg_rn_exports tc_result
379                            doc_hdr  = tcg_doc_hdr tc_result
380                        return (decl,imports,exports,doc_hdr)
381
382       return (tc_result, rn_info)
383
384 -- | Convert a typechecked module to Core
385 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
386 hscDesugar hsc_env mod_summary tc_result
387   = runHsc hsc_env $ hscDesugar' mod_summary tc_result
388
389 hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
390 hscDesugar' mod_summary tc_result
391  = do
392       hsc_env <- getHscEnv
393       r <- ioMsgMaybe $ 
394              deSugar hsc_env (ms_location mod_summary) tc_result
395
396       handleWarnings
397                 -- always check -Werror after desugaring, this is 
398                 -- the last opportunity for warnings to arise before
399                 -- the backend.
400       return r
401
402 -- | Make a 'ModIface' from the results of typechecking.  Used when
403 -- not optimising, and the interface doesn't need to contain any
404 -- unfoldings or other cross-module optimisation info.
405 -- ToDo: the old interface is only needed to get the version numbers,
406 -- we should use fingerprint versions instead.
407 makeSimpleIface :: HscEnv -> 
408                    Maybe ModIface -> TcGblEnv -> ModDetails
409                 -> IO (ModIface,Bool)
410 makeSimpleIface hsc_env maybe_old_iface tc_result details
411   = runHsc hsc_env $
412      ioMsgMaybe $ 
413        mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
414
415 -- | Make a 'ModDetails' from the results of typechecking.  Used when
416 -- typechecking only, as opposed to full compilation.
417 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
418 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
419 \end{code}
420
421 %************************************************************************
422 %*                                                                      *
423                 The main compiler pipeline
424 %*                                                                      *
425 %************************************************************************
426
427                    --------------------------------
428                         The compilation proper
429                    --------------------------------
430
431
432 It's the task of the compilation proper to compile Haskell, hs-boot and
433 core files to either byte-code, hard-code (C, asm, LLVM, ect) or to
434 nothing at all (the module is still parsed and type-checked. This
435 feature is mostly used by IDE's and the likes).
436 Compilation can happen in either 'one-shot', 'batch', 'nothing',
437 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
438 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
439 targets byte-code.
440 The modes are kept separate because of their different types and meanings.
441 In 'one-shot' mode, we're only compiling a single file and can therefore
442 discard the new ModIface and ModDetails. This is also the reason it only
443 targets hard-code; compiling to byte-code or nothing doesn't make sense
444 when we discard the result.
445 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
446 and ModDetails. 'Batch' mode doesn't target byte-code since that require
447 us to return the newly compiled byte-code.
448 'Nothing' mode has exactly the same type as 'batch' mode but they're still
449 kept separate. This is because compiling to nothing is fairly special: We
450 don't output any interface files, we don't run the simplifier and we don't
451 generate any code.
452 'Interactive' mode is similar to 'batch' mode except that we return the
453 compiled byte-code together with the ModIface and ModDetails.
454
455 Trying to compile a hs-boot file to byte-code will result in a run-time
456 error. This is the only thing that isn't caught by the type-system.
457
458 \begin{code}
459
460 -- Status of a compilation to hard-code or nothing.
461 data HscStatus' a
462     = HscNoRecomp
463     | HscRecomp
464        (Maybe FilePath)
465             -- Has stub files.  This is a hack. We can't compile C files here
466             -- since it's done in DriverPipeline. For now we just return True
467             -- if we want the caller to compile them for us.
468        a
469
470 -- This is a bit ugly.  Since we use a typeclass below and would like to avoid
471 -- functional dependencies, we have to parameterise the typeclass over the
472 -- result type.  Therefore we need to artificially distinguish some types.  We
473 -- do this by adding type tags which will simply be ignored by the caller.
474 type HscStatus         = HscStatus' ()
475 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
476     -- INVARIANT: result is @Nothing@ <=> input was a boot file
477
478 type OneShotResult     = HscStatus
479 type BatchResult       = (HscStatus, ModIface, ModDetails)
480 type NothingResult     = (HscStatus, ModIface, ModDetails)
481 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
482
483 -- FIXME: The old interface and module index are only using in 'batch' and
484 --        'interactive' mode. They should be removed from 'oneshot' mode.
485 type Compiler result =  HscEnv
486                      -> ModSummary
487                      -> Bool                -- True <=> source unchanged
488                      -> Maybe ModIface      -- Old interface, if available
489                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
490                      -> IO result
491
492 data HsCompiler a
493   = HsCompiler {
494     -- | Called when no recompilation is necessary.
495     hscNoRecomp :: ModIface
496                 -> Hsc a,
497
498     -- | Called to recompile the module.
499     hscRecompile :: ModSummary -> Maybe Fingerprint
500                  -> Hsc a,
501
502     hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
503                -> Hsc a,
504
505     -- | Code generation for Boot modules.
506     hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
507                      -> Hsc a,
508
509     -- | Code generation for normal modules.
510     hscGenOutput :: ModGuts  -> ModSummary -> Maybe Fingerprint
511                  -> Hsc a
512   }
513
514 genericHscCompile :: HsCompiler a
515                   -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ())
516                   -> HscEnv -> ModSummary -> Bool
517                   -> Maybe ModIface -> Maybe (Int, Int)
518                   -> IO a
519 genericHscCompile compiler hscMessage hsc_env
520                   mod_summary source_unchanged
521                   mb_old_iface0 mb_mod_index
522  = do
523      (recomp_reqd, mb_checked_iface)
524          <- {-# SCC "checkOldIface" #-}
525             checkOldIface hsc_env mod_summary 
526                           source_unchanged mb_old_iface0
527      -- save the interface that comes back from checkOldIface.
528      -- In one-shot mode we don't have the old iface until this
529      -- point, when checkOldIface reads it from the disk.
530      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
531      case mb_checked_iface of
532        Just iface | not recomp_reqd
533            -> do hscMessage hsc_env mb_mod_index False mod_summary
534                  runHsc hsc_env $ hscNoRecomp compiler iface
535        _otherwise
536            -> do hscMessage hsc_env mb_mod_index True mod_summary
537                  runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
538
539 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
540 hscCheckRecompBackend compiler tc_result 
541                    hsc_env mod_summary source_unchanged mb_old_iface _m_of_n
542   = do
543      (recomp_reqd, mb_checked_iface)
544          <- {-# SCC "checkOldIface" #-}
545             checkOldIface hsc_env mod_summary
546                           source_unchanged mb_old_iface
547
548      let mb_old_hash = fmap mi_iface_hash mb_checked_iface
549      case mb_checked_iface of
550        Just iface | not recomp_reqd
551            -> runHsc hsc_env $ 
552                  hscNoRecomp compiler
553                              iface{ mi_globals = Just (tcg_rdr_env tc_result) }
554        _otherwise
555            -> runHsc hsc_env $
556                  hscBackend compiler tc_result mod_summary mb_old_hash
557
558 genericHscRecompile :: HsCompiler a
559                     -> ModSummary -> Maybe Fingerprint
560                     -> Hsc a
561 genericHscRecompile compiler mod_summary mb_old_hash
562   | ExtCoreFile <- ms_hsc_src mod_summary =
563       panic "GHC does not currently support reading External Core files"
564   | otherwise = do
565       tc_result <- hscFileFrontEnd mod_summary
566       hscBackend compiler tc_result mod_summary mb_old_hash
567
568 genericHscBackend :: HsCompiler a
569                   -> TcGblEnv -> ModSummary -> Maybe Fingerprint
570                   -> Hsc a
571 genericHscBackend compiler tc_result mod_summary mb_old_hash
572   | HsBootFile <- ms_hsc_src mod_summary =
573       hscGenBootOutput compiler tc_result mod_summary mb_old_hash
574   | otherwise = do
575       guts <- hscDesugar' mod_summary tc_result
576       hscGenOutput compiler guts mod_summary mb_old_hash
577
578 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
579 compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
580   runHsc hsc_env $
581     hscBackend comp tcg ms' Nothing
582
583 --------------------------------------------------------------
584 -- Compilers
585 --------------------------------------------------------------
586
587 hscOneShotCompiler :: HsCompiler OneShotResult
588 hscOneShotCompiler =
589   HsCompiler {
590
591     hscNoRecomp = \_old_iface -> do
592       hsc_env <- getHscEnv
593       liftIO $ dumpIfaceStats hsc_env
594       return HscNoRecomp
595
596   , hscRecompile = genericHscRecompile hscOneShotCompiler
597
598   , hscBackend = \ tc_result mod_summary mb_old_hash -> do
599        dflags <- getDynFlags
600        case hscTarget dflags of
601          HscNothing -> return (HscRecomp Nothing ())
602          _otherw    -> genericHscBackend hscOneShotCompiler
603                                          tc_result mod_summary mb_old_hash
604
605   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
606        (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
607        hscWriteIface iface changed mod_summary
608        return (HscRecomp Nothing ())
609
610   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
611        guts <- hscSimplify' guts0
612        (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
613        hscWriteIface iface changed mod_summary
614        hasStub <- hscGenHardCode cgguts mod_summary
615        return (HscRecomp hasStub ())
616   }
617
618 -- Compile Haskell, boot and extCore in OneShot mode.
619 hscCompileOneShot :: Compiler OneShotResult
620 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
621   = do
622        -- One-shot mode needs a knot-tying mutable variable for interface
623        -- files.  See TcRnTypes.TcGblEnv.tcg_type_env_var.
624       type_env_var <- newIORef emptyNameEnv
625       let
626          mod = ms_mod mod_summary
627          hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
628       ---
629       genericHscCompile hscOneShotCompiler
630                         oneShotMsg hsc_env' mod_summary src_changed
631                         mb_old_iface mb_i_of_n
632
633
634 hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
635 hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
636
637 --------------------------------------------------------------
638
639 hscBatchCompiler :: HsCompiler BatchResult
640 hscBatchCompiler =
641   HsCompiler {
642
643     hscNoRecomp = \iface -> do
644        details <- genModDetails iface
645        return (HscNoRecomp, iface, details)
646
647   , hscRecompile = genericHscRecompile hscBatchCompiler
648
649   , hscBackend = genericHscBackend hscBatchCompiler
650
651   , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
652        (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
653        hscWriteIface iface changed mod_summary
654        return (HscRecomp Nothing (), iface, details)
655
656   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
657        guts <- hscSimplify' guts0
658        (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
659        hscWriteIface iface changed mod_summary
660        hasStub <- hscGenHardCode cgguts mod_summary
661        return (HscRecomp hasStub (), iface, details)
662   }
663
664 -- Compile Haskell, boot and extCore in batch mode.
665 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
666 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
667
668 hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
669 hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
670
671 --------------------------------------------------------------
672
673 hscInteractiveCompiler :: HsCompiler InteractiveResult
674 hscInteractiveCompiler =
675   HsCompiler {
676     hscNoRecomp = \iface -> do
677        details <- genModDetails iface
678        return (HscNoRecomp, iface, details)
679
680   , hscRecompile = genericHscRecompile hscInteractiveCompiler
681
682   , hscBackend = genericHscBackend hscInteractiveCompiler
683
684   , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
685        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
686        return (HscRecomp Nothing Nothing, iface, details)
687
688   , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
689        guts <- hscSimplify' guts0
690        (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
691        hscInteractive (iface, details, cgguts) mod_summary
692   }
693
694 -- Compile Haskell, extCore to bytecode.
695 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
696 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
697
698 hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
699 hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
700
701 --------------------------------------------------------------
702
703 hscNothingCompiler :: HsCompiler NothingResult
704 hscNothingCompiler =
705   HsCompiler {
706     hscNoRecomp = \iface -> do
707        details <- genModDetails iface
708        return (HscNoRecomp, iface, details)
709
710   , hscRecompile = genericHscRecompile hscNothingCompiler
711
712   , hscBackend = \tc_result _mod_summary mb_old_iface -> do
713        handleWarnings
714        (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
715        return (HscRecomp Nothing (), iface, details)
716
717   , hscGenBootOutput = \_ _ _ ->
718         panic "hscCompileNothing: hscGenBootOutput should not be called"
719
720   , hscGenOutput = \_ _ _ ->
721         panic "hscCompileNothing: hscGenOutput should not be called"
722   }
723
724 -- Type-check Haskell and .hs-boot only (no external core)
725 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
726 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
727
728 hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
729 hscNothingBackendOnly = compilerBackend hscNothingCompiler
730
731 --------------------------------------------------------------
732 -- NoRecomp handlers
733 --------------------------------------------------------------
734
735 genModDetails :: ModIface -> Hsc ModDetails
736 genModDetails old_iface
737   = do
738       hsc_env <- getHscEnv
739       new_details <- {-# SCC "tcRnIface" #-}
740                      liftIO $ initIfaceCheck hsc_env $
741                               typecheckIface old_iface
742       liftIO $ dumpIfaceStats hsc_env
743       return new_details
744
745 --------------------------------------------------------------
746 -- Progress displayers.
747 --------------------------------------------------------------
748
749 oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
750 oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
751          if recomp
752             then return ()
753             else compilationProgressMsg (hsc_dflags hsc_env) $
754                      "compilation IS NOT required"
755
756 batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()
757 batchMsg hsc_env mb_mod_index recomp mod_summary
758   = do
759          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
760                            (showModuleIndex mb_mod_index ++
761                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
762          if recomp
763             then showMsg "Compiling "
764             else if verbosity (hsc_dflags hsc_env) >= 2
765                     then showMsg "Skipping  "
766                     else return ()
767
768 --------------------------------------------------------------
769 -- FrontEnds
770 --------------------------------------------------------------
771
772 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
773 hscFileFrontEnd mod_summary = do
774     rdr_module <- hscParse' mod_summary
775     hsc_env <- getHscEnv
776     tcg_env <-
777         {-# SCC "Typecheck-Rename" #-}
778         ioMsgMaybe $
779             tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
780     dflags <- getDynFlags
781     -- XXX: See Note [Safe Haskell API]
782     if safeHaskellOn dflags
783         then do
784             tcg_env1 <- checkSafeImports dflags hsc_env tcg_env
785             if safeLanguageOn dflags
786                 then do
787                     -- we also nuke user written RULES.
788                     logWarnings $ warns (tcg_rules tcg_env1)
789                     return tcg_env1 { tcg_rules = [] }
790                 else do
791                     -- Wipe out trust required packages if the module isn't
792                     -- trusted. Not doing this doesn't cause any problems
793                     -- but means the hi file will say some pkgs should be
794                     -- trusted when they don't need to be (since its an
795                     -- untrusted module) and we don't force them to be.
796                     let imps  = tcg_imports tcg_env1
797                         imps' = imps { imp_trust_pkgs = [] }
798                     return tcg_env1 { tcg_imports = imps' }
799
800         else
801             return tcg_env
802
803     where
804         warns rules = listToBag $ map warnRules rules
805         warnRules (L loc (HsRule n _ _ _ _ _ _)) =
806             mkPlainWarnMsg loc $
807                 text "Rule \"" <> ftext n <> text "\" ignored" $+$
808                 text "User defined rules are disabled under Safe Haskell"
809
810 --------------------------------------------------------------
811 -- Safe Haskell
812 --------------------------------------------------------------
813
814 -- Note [Safe Haskell API]
815 -- ~~~~~~~~~~~~~~~~~~~~~~
816 -- XXX: We only call this in hscFileFrontend and don't expose
817 -- it to the GHC API. External users of GHC can't properly use
818 -- the GHC API and Safe Haskell.
819
820
821 -- Note [Safe Haskell Trust Check]
822 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
823 -- Safe Haskell checks that an import is trusted according to the following
824 -- rules for an import of module M that resides in Package P:
825 --
826 --   * If M is recorded as Safe and all its trust dependencies are OK
827 --     then M is considered safe.
828 --   * If M is recorded as Trustworthy and P is considered trusted and
829 --     all M's trust dependencies are OK then M is considered safe.
830 --
831 -- By trust dependencies we mean that the check is transitive. So if
832 -- a module M that is Safe relies on a module N that is trustworthy,
833 -- importing module M will first check (according to the second case)
834 -- that N is trusted before checking M is trusted.
835 --
836 -- This is a minimal description, so please refer to the user guide
837 -- for more details. The user guide is also considered the authoritative
838 -- source in this matter, not the comments or code.
839
840
841 -- | Validate that safe imported modules are actually safe.
842 -- For modules in the HomePackage (the package the module we
843 -- are compiling in resides) this just involves checking its
844 -- trust type is 'Safe' or 'Trustworthy'. For modules that
845 -- reside in another package we also must check that the
846 -- external pacakge is trusted. See the Note [Safe Haskell
847 -- Trust Check] above for more information.
848 --
849 -- The code for this is quite tricky as the whole algorithm
850 -- is done in a few distinct phases in different parts of the
851 -- code base. See RnNames.rnImportDecl for where package trust
852 -- dependencies for a module are collected and unioned.
853 -- Specifically see the Note [RnNames . Tracking Trust Transitively]
854 -- and the Note [RnNames . Trust Own Package].
855 checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
856 checkSafeImports dflags hsc_env tcg_env
857     = do
858         imps <- mapM condense imports'
859         pkgs <- mapM checkSafe imps
860         checkPkgTrust pkg_reqs
861
862         -- add in trusted package requirements for this module
863         let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
864         return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
865
866     where
867         imp_info = tcg_imports tcg_env     -- ImportAvails
868         imports  = imp_mods imp_info       -- ImportedMods
869         imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
870         pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
871
872         condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
873         condense (_, [])   = panic "HscMain.condense: Pattern match failure!"
874         condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
875                                 return (m, l, s)
876         
877         -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
878         cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
879         cond' v1@(m1,_,l1,s1) (_,_,_,s2)
880             | s1 /= s2
881             = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1
882                     (text "Module" <+> ppr m1 <+> (text $ "is imported"
883                         ++ " both as a safe and unsafe import!"))
884             | otherwise
885             = return v1
886
887         lookup' :: Module -> Hsc (Maybe ModIface)
888         lookup' m = do
889             hsc_eps <- liftIO $ hscEPS hsc_env
890             let pkgIfaceT = eps_PIT hsc_eps
891                 homePkgT = hsc_HPT hsc_env
892                 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
893             return iface
894
895         isHomePkg :: Module -> Bool
896         isHomePkg m
897             | thisPackage dflags == modulePackageId m = True
898             | otherwise                               = False
899
900         -- | Check the package a module resides in is trusted.
901         -- Safe compiled modules are trusted without requiring
902         -- that their package is trusted. For trustworthy modules,
903         -- modules in the home package are trusted but otherwise
904         -- we check the package trust flag.
905         packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
906         packageTrusted Sf_Safe False _ = True
907         packageTrusted _ _ m
908             | isHomePkg m = True
909             | otherwise   = trusted $ getPackageDetails (pkgState dflags)
910                                                         (modulePackageId m)
911
912         -- Is a module trusted? Return Nothing if True, or a String
913         -- if it isn't, containing the reason it isn't
914         isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc)
915         isModSafe m l = do
916             iface <- lookup' m
917             case iface of
918                 -- can't load iface to check trust!
919                 Nothing -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
920                             $ text "Can't load the interface file for" <+> ppr m <>
921                               text ", to check that it can be safely imported"
922
923                 -- got iface, check trust
924                 Just iface' -> do
925                     let trust = getSafeMode $ mi_trust iface'
926                         trust_own_pkg = mi_trust_pkg iface'
927                         -- check module is trusted
928                         safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
929                         -- check package is trusted
930                         safeP = packageTrusted trust trust_own_pkg m
931                     if safeM && safeP
932                         then return Nothing
933                         else return $ Just $ if safeM
934                             then text "The package (" <> ppr (modulePackageId m) <>
935                                  text ") the module resides in isn't trusted."
936                             else text "The module itself isn't safe."
937
938         -- Here we check the transitive package trust requirements are OK still.
939         checkPkgTrust :: [PackageId] -> Hsc ()
940         checkPkgTrust pkgs = do
941             case errors of
942                 [] -> return ()
943                 _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
944             where
945                 errors = catMaybes $ map go pkgs
946                 go pkg
947                     | trusted $ getPackageDetails (pkgState dflags) pkg
948                     = Nothing
949                     | otherwise
950                     = Just $ mkPlainErrMsg noSrcSpan
951                            $ text "The package (" <> ppr pkg <> text ") is required"
952                           <> text " to be trusted but it isn't!"
953
954         checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
955         checkSafe (_, _, False) = return Nothing
956         checkSafe (m, l, True ) = do
957             module_safe <- isModSafe m l
958             case module_safe of
959                 Nothing -> return pkg
960                 Just s  -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
961                             $ ppr m <+> text "can't be safely imported!"
962                                 <+> s
963             where pkg | isHomePkg m = Nothing
964                       | otherwise   = Just (modulePackageId m)
965                             
966 --------------------------------------------------------------
967 -- Simplifiers
968 --------------------------------------------------------------
969
970 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
971 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
972
973 hscSimplify' :: ModGuts -> Hsc ModGuts
974 hscSimplify' ds_result
975   = do hsc_env <- getHscEnv
976        {-# SCC "Core2Core" #-}
977          liftIO $ core2core hsc_env ds_result
978
979 --------------------------------------------------------------
980 -- Interface generators
981 --------------------------------------------------------------
982
983 hscSimpleIface :: TcGblEnv
984                -> Maybe Fingerprint
985                -> Hsc (ModIface, Bool, ModDetails)
986 hscSimpleIface tc_result mb_old_iface
987   = do 
988        hsc_env <- getHscEnv
989        details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
990        (new_iface, no_change)
991            <- {-# SCC "MkFinalIface" #-}
992               ioMsgMaybe $ 
993                 mkIfaceTc hsc_env mb_old_iface details tc_result
994        -- And the answer is ...
995        liftIO $ dumpIfaceStats hsc_env
996        return (new_iface, no_change, details)
997
998 hscNormalIface :: ModGuts
999                -> Maybe Fingerprint
1000                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1001 hscNormalIface simpl_result mb_old_iface
1002   = do 
1003        hsc_env <- getHscEnv
1004        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1005                              liftIO $ tidyProgram hsc_env simpl_result
1006
1007             -- BUILD THE NEW ModIface and ModDetails
1008             --  and emit external core if necessary
1009             -- This has to happen *after* code gen so that the back-end
1010             -- info has been set.  Not yet clear if it matters waiting
1011             -- until after code output
1012        (new_iface, no_change)
1013            <- {-# SCC "MkFinalIface" #-}
1014               ioMsgMaybe $ 
1015                    mkIface hsc_env mb_old_iface details simpl_result
1016
1017        -- Emit external core
1018        -- This should definitely be here and not after CorePrep,
1019        -- because CorePrep produces unqualified constructor wrapper declarations,
1020        -- so its output isn't valid External Core (without some preprocessing).
1021        liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
1022        liftIO $ dumpIfaceStats hsc_env
1023
1024             -- Return the prepared code.
1025        return (new_iface, no_change, details, cg_guts)
1026
1027 --------------------------------------------------------------
1028 -- BackEnd combinators
1029 --------------------------------------------------------------
1030
1031 hscWriteIface :: ModIface
1032               -> Bool
1033               -> ModSummary
1034               -> Hsc ()
1035
1036 hscWriteIface iface no_change mod_summary
1037     = do dflags <- getDynFlags
1038          unless no_change
1039            $ liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
1040
1041 -- | Compile to hard-code.
1042 hscGenHardCode :: CgGuts -> ModSummary
1043                -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1044 hscGenHardCode cgguts mod_summary
1045   = do
1046     hsc_env <- getHscEnv
1047     liftIO $ do
1048          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1049                      -- From now on, we just use the bits we need.
1050                      cg_module   = this_mod,
1051                      cg_binds    = core_binds,
1052                      cg_tycons   = tycons,
1053                      cg_foreign  = foreign_stubs0,
1054                      cg_dep_pkgs = dependencies,
1055                      cg_hpc_info = hpc_info } = cgguts
1056              dflags = hsc_dflags hsc_env
1057              platform = targetPlatform dflags
1058              location = ms_location mod_summary
1059              data_tycons = filter isDataTyCon tycons
1060              -- cg_tycons includes newtypes, for the benefit of External Core,
1061              -- but we don't generate any code for newtypes
1062
1063          -------------------
1064          -- PREPARE FOR CODE GENERATION
1065          -- Do saturation and convert to A-normal form
1066          prepd_binds <- {-# SCC "CorePrep" #-}
1067                         corePrepPgm dflags core_binds data_tycons ;
1068          -----------------  Convert to STG ------------------
1069          (stg_binds, cost_centre_info)
1070              <- {-# SCC "CoreToStg" #-}
1071                 myCoreToStg dflags this_mod prepd_binds 
1072
1073          let prof_init = profilingInitCode this_mod cost_centre_info
1074              foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1075
1076          ------------------  Code generation ------------------
1077          
1078          cmms <- if dopt Opt_TryNewCodeGen dflags
1079                  then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
1080                                  cost_centre_info
1081                                  stg_binds hpc_info
1082                          return cmms
1083                  else {-# SCC "CodeGen" #-}
1084                        codeGen dflags this_mod data_tycons
1085                                cost_centre_info
1086                                stg_binds hpc_info
1087
1088          --- Optionally run experimental Cmm transformations ---
1089          cmms <- optionallyConvertAndOrCPS hsc_env cmms
1090                  -- unless certain dflags are on, the identity function
1091          ------------------  Code output -----------------------
1092          rawcmms <- cmmToRawCmm cmms
1093          dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
1094          (_stub_h_exists, stub_c_exists)
1095              <- codeOutput dflags this_mod location foreign_stubs 
1096                 dependencies rawcmms
1097          return stub_c_exists
1098
1099 hscInteractive :: (ModIface, ModDetails, CgGuts)
1100                -> ModSummary
1101                -> Hsc (InteractiveStatus, ModIface, ModDetails)
1102 #ifdef GHCI
1103 hscInteractive (iface, details, cgguts) mod_summary
1104     = do
1105          dflags <- getDynFlags
1106          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1107                      -- From now on, we just use the bits we need.
1108                      cg_module   = this_mod,
1109                      cg_binds    = core_binds,
1110                      cg_tycons   = tycons,
1111                      cg_foreign  = foreign_stubs,
1112                      cg_modBreaks = mod_breaks } = cgguts
1113
1114              location = ms_location mod_summary
1115              data_tycons = filter isDataTyCon tycons
1116              -- cg_tycons includes newtypes, for the benefit of External Core,
1117              -- but we don't generate any code for newtypes
1118
1119          -------------------
1120          -- PREPARE FOR CODE GENERATION
1121          -- Do saturation and convert to A-normal form
1122          prepd_binds <- {-# SCC "CorePrep" #-}
1123                         liftIO $ corePrepPgm dflags core_binds data_tycons ;
1124          -----------------  Generate byte code ------------------
1125          comp_bc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks
1126          ------------------ Create f-x-dynamic C-side stuff ---
1127          (_istub_h_exists, istub_c_exists) 
1128              <- liftIO $ outputForeignStubs dflags this_mod
1129                                             location foreign_stubs
1130          return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
1131                 , iface, details)
1132 #else
1133 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1134 #endif
1135
1136 ------------------------------
1137
1138 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
1139 hscCompileCmmFile hsc_env filename
1140   = runHsc hsc_env $ do
1141       let dflags = hsc_dflags hsc_env
1142       cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1143       liftIO $ do
1144         cmms <- optionallyConvertAndOrCPS hsc_env [cmm]
1145         rawCmms <- cmmToRawCmm cmms
1146         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
1147         return ()
1148   where
1149         no_mod = panic "hscCmmFile: no_mod"
1150         no_loc = ModLocation{ ml_hs_file  = Just filename,
1151                               ml_hi_file  = panic "hscCmmFile: no hi file",
1152                               ml_obj_file = panic "hscCmmFile: no obj file" }
1153
1154 -------------------- Stuff for new code gen ---------------------
1155
1156 tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
1157                 -> CollectedCCs
1158                 -> [(StgBinding,[(Id,[Id])])]
1159                 -> HpcInfo
1160                 -> IO [Cmm]
1161 tryNewCodeGen hsc_env this_mod data_tycons
1162               cost_centre_info stg_binds hpc_info =
1163   do    { let dflags = hsc_dflags hsc_env
1164               platform = targetPlatform dflags
1165         ; prog <- StgCmm.codeGen dflags this_mod data_tycons
1166                          cost_centre_info stg_binds hpc_info
1167         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" 
1168                 (pprCmms platform prog)
1169
1170         -- We are building a single SRT for the entire module, so
1171         -- we must thread it through all the procedures as we cps-convert them.
1172         ; us <- mkSplitUniqSupply 'S'
1173         ; let initTopSRT = initUs_ us emptySRT
1174         ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
1175
1176         ; let prog' = map cmmOfZgraph (srtToData topSRT : prog)
1177         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
1178         ; return prog' }
1179
1180
1181 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
1182 optionallyConvertAndOrCPS hsc_env cmms =
1183     do let dflags = hsc_dflags hsc_env
1184         --------  Optionally convert to and from zipper ------
1185        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
1186                then mapM (testCmmConversion hsc_env) cmms
1187                else return cmms
1188        return cmms
1189
1190
1191 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
1192 testCmmConversion hsc_env cmm =
1193     do let dflags = hsc_dflags hsc_env
1194            platform = targetPlatform dflags
1195        showPass dflags "CmmToCmm"
1196        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm)
1197        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
1198        us <- mkSplitUniqSupply 'C'
1199        let zgraph = initUs_ us (cmmToZgraph platform cmm)
1200        chosen_graph <-
1201         if dopt Opt_RunCPSZ dflags
1202             then do us <- mkSplitUniqSupply 'S'
1203                     let topSRT = initUs_ us emptySRT
1204                     (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph
1205                     return zgraph
1206             else return (runCmmContFlowOpts zgraph)
1207        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph)
1208        showPass dflags "Convert from Z back to Cmm"
1209        let cvt = cmmOfZgraph chosen_graph
1210        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt)
1211        return cvt
1212
1213 myCoreToStg :: DynFlags -> Module -> [CoreBind]
1214             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
1215                   , CollectedCCs) -- cost centre info (declared and used)
1216
1217 myCoreToStg dflags this_mod prepd_binds
1218  = do 
1219       stg_binds <- {-# SCC "Core2Stg" #-}
1220              coreToStg (thisPackage dflags) prepd_binds
1221
1222       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
1223              stg2stg dflags this_mod stg_binds
1224
1225       return (stg_binds2, cost_centre_info)
1226 \end{code}
1227
1228
1229 %************************************************************************
1230 %*                                                                      *
1231 \subsection{Compiling a do-statement}
1232 %*                                                                      *
1233 %************************************************************************
1234
1235 When the UnlinkedBCOExpr is linked you get an HValue of type
1236         IO [HValue]
1237 When you run it you get a list of HValues that should be 
1238 the same length as the list of names; add them to the ClosureEnv.
1239
1240 A naked expression returns a singleton Name [it].
1241
1242         What you type                   The IO [HValue] that hscStmt returns
1243         -------------                   ------------------------------------
1244         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1245                                         bindings: [x,y,...]
1246
1247         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1248                                         bindings: [x,y,...]
1249
1250         expr (of IO type)       ==>     expr >>= \ v -> return [v]
1251           [NB: result not printed]      bindings: [it]
1252           
1253
1254         expr (of non-IO type, 
1255           result showable)      ==>     let v = expr in print v >> return [v]
1256                                         bindings: [it]
1257
1258         expr (of non-IO type, 
1259           result not showable)  ==>     error
1260
1261 \begin{code}
1262 #ifdef GHCI
1263 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
1264   :: HscEnv
1265   -> String                     -- The statement
1266   -> IO (Maybe ([Id], HValue))
1267      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
1268 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1269
1270 hscStmtWithLocation     -- Compile a stmt all the way to an HValue, but don't run it
1271   :: HscEnv
1272   -> String                     -- The statement
1273   -> String                     -- the source
1274   -> Int                        -- ^ starting line
1275   -> IO (Maybe ([Id], HValue))
1276      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
1277 hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
1278     maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1279     case maybe_stmt of
1280       Nothing -> return Nothing
1281       Just parsed_stmt -> do  -- The real stuff
1282
1283              -- Rename and typecheck it
1284         let icontext = hsc_IC hsc_env
1285         (ids, tc_expr) <- ioMsgMaybe $ 
1286                             tcRnStmt hsc_env icontext parsed_stmt
1287             -- Desugar it
1288         let rdr_env  = ic_rn_gbl_env icontext
1289             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
1290         ds_expr <- ioMsgMaybe $
1291                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1292         handleWarnings
1293
1294         -- Then desugar, code gen, and link it
1295         let src_span = srcLocSpan interactiveSrcLoc
1296         hsc_env <- getHscEnv
1297         hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1298
1299         return $ Just (ids, hval)
1300
1301 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1302 hscImport hsc_env str = runHsc hsc_env $ do
1303     (L _ (HsModule{hsmodImports=is})) <- 
1304        hscParseThing parseModule str
1305     case is of
1306         [i] -> return (unLoc i)
1307         _ -> liftIO $ throwOneError $
1308                 mkPlainErrMsg noSrcSpan $
1309                     ptext (sLit "parse error in import declaration")
1310
1311 hscTcExpr       -- Typecheck an expression (but don't run it)
1312   :: HscEnv
1313   -> String                     -- The expression
1314   -> IO Type
1315
1316 hscTcExpr hsc_env expr = runHsc hsc_env $ do
1317     maybe_stmt <- hscParseStmt expr
1318     case maybe_stmt of
1319         Just (L _ (ExprStmt expr _ _ _)) ->
1320             ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1321         _ ->
1322             liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
1323                 (text "not an expression:" <+> quotes (text expr))
1324
1325 -- | Find the kind of a type
1326 hscKcType
1327   :: HscEnv
1328   -> String                     -- ^ The type
1329   -> IO Kind
1330
1331 hscKcType hsc_env str = runHsc hsc_env $ do
1332     ty <- hscParseType str
1333     ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty
1334
1335 #endif
1336 \end{code}
1337
1338 \begin{code}
1339 #ifdef GHCI
1340 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1341 hscParseStmt = hscParseThing parseStmt
1342
1343 hscParseStmtWithLocation :: String -> Int 
1344                          -> String -> Hsc (Maybe (LStmt RdrName))
1345 hscParseStmtWithLocation source linenumber stmt = 
1346   hscParseThingWithLocation source linenumber parseStmt stmt
1347
1348 hscParseType :: String -> Hsc (LHsType RdrName)
1349 hscParseType = hscParseThing parseType
1350 #endif
1351
1352 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1353 hscParseIdentifier hsc_env str = runHsc hsc_env $ 
1354                                    hscParseThing parseIdentifier str
1355
1356 hscParseThing :: (Outputable thing)
1357               => Lexer.P thing
1358               -> String
1359               -> Hsc thing
1360 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1361
1362 hscParseThingWithLocation :: (Outputable thing)
1363               => String -> Int 
1364               -> Lexer.P thing
1365               -> String
1366               -> Hsc thing
1367 hscParseThingWithLocation source linenumber parser str
1368  = {-# SCC "Parser" #-} do
1369       dflags <- getDynFlags
1370       liftIO $ showPass dflags "Parser"
1371
1372       let buf = stringToStringBuffer str
1373           loc  = mkRealSrcLoc (fsLit source) linenumber 1
1374
1375       case unP parser (mkPState dflags buf loc) of
1376
1377         PFailed span err -> do
1378           let msg = mkPlainErrMsg span err
1379           liftIO $ throwIO (mkSrcErr (unitBag msg))
1380
1381         POk pst thing -> do
1382           logWarningsReportErrors (getMessages pst)
1383           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1384           return thing
1385 \end{code}
1386
1387 \begin{code}
1388 hscCompileCore :: HscEnv
1389                -> Bool
1390                -> ModSummary
1391                -> [CoreBind]
1392                -> IO ()
1393
1394 hscCompileCore hsc_env simplify mod_summary binds
1395   = runHsc hsc_env $ do
1396       let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1397                                   | otherwise = return mod_guts
1398       guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1399       (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1400       hscWriteIface iface changed mod_summary
1401       _ <- hscGenHardCode cgguts mod_summary
1402       return ()
1403
1404 -- Makes a "vanilla" ModGuts.
1405 mkModGuts :: Module -> [CoreBind] -> ModGuts
1406 mkModGuts mod binds = ModGuts {
1407   mg_module = mod,
1408   mg_boot = False,
1409   mg_exports = [],
1410   mg_deps = noDependencies,
1411   mg_dir_imps = emptyModuleEnv,
1412   mg_used_names = emptyNameSet,
1413   mg_rdr_env = emptyGlobalRdrEnv,
1414   mg_fix_env = emptyFixityEnv,
1415   mg_types = emptyTypeEnv,
1416   mg_insts = [],
1417   mg_fam_insts = [],
1418   mg_rules = [],
1419   mg_vect_decls = [],
1420   mg_binds = binds,
1421   mg_foreign = NoStubs,
1422   mg_warns = NoWarnings,
1423   mg_anns = [],
1424   mg_hpc_info = emptyHpcInfo False,
1425   mg_modBreaks = emptyModBreaks,
1426   mg_vect_info = noVectInfo,
1427   mg_inst_env = emptyInstEnv,
1428   mg_fam_inst_env = emptyFamInstEnv,
1429   mg_trust_pkg = False
1430 }
1431 \end{code}
1432
1433 %************************************************************************
1434 %*                                                                      *
1435         Desugar, simplify, convert to bytecode, and link an expression
1436 %*                                                                      *
1437 %************************************************************************
1438
1439 \begin{code}
1440 #ifdef GHCI
1441 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1442 hscCompileCoreExpr hsc_env srcspan ds_expr
1443   | rtsIsProfiled
1444   = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1445           -- Otherwise you get a seg-fault when you run it
1446
1447   | otherwise = do
1448     let dflags = hsc_dflags hsc_env
1449     let lint_on = dopt Opt_DoCoreLinting dflags
1450
1451         -- Simplify it
1452     simpl_expr <- simplifyExpr dflags ds_expr
1453
1454         -- Tidy it (temporary, until coreSat does cloning)
1455     let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1456
1457         -- Prepare for codegen
1458     prepd_expr <- corePrepExpr dflags tidy_expr
1459
1460         -- Lint if necessary
1461         -- ToDo: improve SrcLoc
1462     when lint_on $
1463        let ictxt = hsc_IC hsc_env
1464            tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt)))
1465        in
1466            case lintUnfolding noSrcLoc tyvars prepd_expr of
1467               Just err -> pprPanic "hscCompileCoreExpr" err
1468               Nothing  -> return ()
1469
1470           -- Convert to BCOs
1471     bcos <- coreExprToBCOs dflags prepd_expr
1472
1473         -- link it
1474     hval <- linkExpr hsc_env srcspan bcos
1475
1476     return hval
1477 #endif
1478 \end{code}
1479
1480
1481 %************************************************************************
1482 %*                                                                      *
1483         Statistics on reading interfaces
1484 %*                                                                      *
1485 %************************************************************************
1486
1487 \begin{code}
1488 dumpIfaceStats :: HscEnv -> IO ()
1489 dumpIfaceStats hsc_env
1490   = do  { eps <- readIORef (hsc_EPS hsc_env)
1491         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1492                     "Interface statistics"
1493                     (ifaceStats eps) }
1494   where
1495     dflags = hsc_dflags hsc_env
1496     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1497     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1498 \end{code}
1499
1500 %************************************************************************
1501 %*                                                                      *
1502         Progress Messages: Module i of n
1503 %*                                                                      *
1504 %************************************************************************
1505
1506 \begin{code}
1507 showModuleIndex :: Maybe (Int, Int) -> String
1508 showModuleIndex Nothing = ""
1509 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1510     where
1511         n_str = show n
1512         i_str = show i
1513         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1514 \end{code}