HscMain.lhs 33.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
3
%
4

5
6
7
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}

\begin{code}
8
9
10
11
module HscMain
    ( newHscEnv, hscCmmFile
    , hscFileCheck
    , hscParseIdentifier
12
#ifdef GHCI
13
14
    , hscStmt, hscTcExpr, hscKcType
    , compileExpr
15
#endif
16
    , hscCompileOneShot     -- :: Compiler HscStatus
17
18
    , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
    , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
19
20
21
22
23
    , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
    , HscStatus (..)
    , InteractiveStatus (..)
    , HscChecked (..)
    ) where
24

25
#include "HsVersions.h"
26

27
#ifdef GHCI
28
import HsSyn		( Stmt(..), LHsExpr, LStmt, LHsType )
29
import Module		( Module )
30
31
32
import CodeOutput	( outputForeignStubs )
import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
import Linker		( HValue, linkExpr )
33
import CoreTidy		( tidyExpr )
34
import CorePrep		( corePrepExpr )
35
import Flattening	( flattenExpr )
36
37
import Desugar          ( deSugarExpr )
import SimplCore        ( simplifyExpr )
38
import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
39
40
import Type		( Type )
import PrelNames	( iNTERACTIVE )
41
import Kind		( Kind )
42
import CoreLint		( lintUnfolding )
43
import DsMeta		( templateHaskellNames )
44
import SrcLoc		( noSrcLoc )
45
import VarEnv		( emptyTidyEnv )
46
47
#endif

48
import Var		( Id )
49
import Module		( emptyModuleEnv, ModLocation(..) )
50
import RdrName		( GlobalRdrEnv, RdrName )
51
import HsSyn		( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
52
import SrcLoc		( Located(..) )
53
import StringBuffer	( hGetStringBuffer, stringToStringBuffer )
54
import Parser
55
import Lexer		( P(..), ParseResult(..), mkPState )
56
import SrcLoc		( mkSrcLoc )
57
58
import TcRnDriver	( tcRnModule, tcRnExtCore )
import TcIface		( typecheckIface )
59
import TcRnMonad	( initIfaceCheck, TcGblEnv(..) )
60
61
62
import IfaceEnv		( initNameCache )
import LoadIface	( ifaceStats, initExternalPackageState )
import PrelInfo		( wiredInThings, basicKnownKeyNames )
63
import MkIface		( checkOldIface, mkIface, writeIfaceFile )
64
import Desugar          ( deSugar )
65
import Flattening       ( flatten )
66
import SimplCore        ( core2core )
67
import TidyPgm		( tidyProgram, mkBootModDetails )
68
import CorePrep		( corePrepPgm )
69
import CoreToStg	( coreToStg )
70
import TyCon		( isDataTyCon )
71
import Packages		( mkHomeModules )
72
import Name		( Name, NamedThing(..) )
73
74
import SimplStg		( stg2stg )
import CodeGen		( codeGen )
75
import CmmParse		( parseCmmFile )
76
import CodeOutput	( codeOutput )
77

78
import DynFlags
79
import ErrUtils
80
import UniqSupply	( mkSplitUniqSupply )
81

82
import Outputable
83
import HscStats		( ppSourceStats )
84
import HscTypes
85
86
87
import MkExternalCore	( emitExternalCore )
import ParserCore
import ParserCoreUtils
88
import FastString
89
import Maybes		( expectJust )
90
import Bag		( unitBag )
91
import Monad		( unless )
92
import IO
93
import DATA_IOREF	( newIORef, readIORef )
94
95
\end{code}

96
97
98

%************************************************************************
%*									*
99
100
101
102
103
		Initialisation
%*									*
%************************************************************************

\begin{code}
104
105
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags
106
107
108
  = do 	{ eps_var <- newIORef initExternalPackageState
	; us      <- mkSplitUniqSupply 'r'
	; nc_var  <- newIORef (initNameCache us knownKeyNames)
109
	; fc_var  <- newIORef emptyModuleEnv
110
	; return (HscEnv { hsc_dflags = dflags,
111
112
113
			   hsc_targets = [],
			   hsc_mod_graph = [],
			   hsc_IC     = emptyInteractiveContext,
114
115
			   hsc_HPT    = emptyHomePackageTable,
			   hsc_EPS    = eps_var,
116
117
			   hsc_NC     = nc_var,
			   hsc_FC     = fc_var } ) }
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
			

knownKeyNames :: [Name]	-- Put here to avoid loops involving DsMeta,
			-- where templateHaskellNames are defined
knownKeyNames = map getName wiredInThings 
	      ++ basicKnownKeyNames
#ifdef GHCI
	      ++ templateHaskellNames
#endif
\end{code}


%************************************************************************
%*									*
		The main compiler pipeline
133
134
135
%*									*
%************************************************************************

136
137
138
139
140
141
142
143
144
                   --------------------------------
                        The compilation proper
                   --------------------------------


It's the task of the compilation proper to compile Haskell, hs-boot and
core files to either byte-code, hard-code (C, asm, Java, ect) or to
nothing at all (the module is still parsed and type-checked. This
feature is mostly used by IDE's and the likes).
145
146
147
148
149
Compilation can happen in either 'one-shot', 'batch', 'nothing',
or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
targets byte-code.
The modes are kept separate because of their different types and meanings.
150
151
152
In 'one-shot' mode, we're only compiling a single file and can therefore
discard the new ModIface and ModDetails. This is also the reason it only
targets hard-code; compiling to byte-code or nothing doesn't make sense
153
154
155
156
157
158
159
160
161
162
163
when we discard the result.
'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
and ModDetails. 'Batch' mode doesn't target byte-code since that require
us to return the newly compiled byte-code.
'Nothing' mode has exactly the same type as 'batch' mode but they're still
kept separate. This is because compiling to nothing is fairly special: We
don't output any interface files, we don't run the simplifier and we don't
generate any code.
'Interactive' mode is similar to 'batch' mode except that we return the
compiled byte-code together with the ModIface and ModDetails.

164
165
166
Trying to compile a hs-boot file to byte-code will result in a run-time
error. This is the only thing that isn't caught by the type-system.

167
\begin{code}
168

169
170
data HscChecked
    = HscChecked
171
        -- parsed
172
        (Located (HsModule RdrName))
173
        -- renamed
174
        (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
175
        -- typechecked
176
        (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
177

178

179
-- Status of a compilation to hard-code or nothing.
180
data HscStatus
181
182
183
184
185
186
187
188
    = HscNoRecomp
    | HscRecomp  Bool -- Has stub files.
                      -- This is a hack. We can't compile C files here
                      -- since it's done in DriverPipeline. For now we
                      -- just return True if we want the caller to compile
                      -- it for us.

-- Status of a compilation to byte-code.
189
190
191
192
193
194
data InteractiveStatus
    = InteractiveNoRecomp
    | InteractiveRecomp Bool     -- Same as HscStatus
                        CompiledByteCode


195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
-- I want Control.Monad.State! --Lemmih 03/07/2006
newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)}

instance Monad Comp where
    g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s'
    return a = Comp $ \s -> return (a,s)
    fail = error

evalComp :: Comp a -> CompState -> IO a
evalComp comp st = do (val,_st') <- runComp comp st
                      return val

data CompState
    = CompState
    { compHscEnv     :: HscEnv
    , compModSummary :: ModSummary
    , compOldIface   :: Maybe ModIface
    }

get :: Comp CompState
get = Comp $ \s -> return (s,s)

gets :: (CompState -> a) -> Comp a
gets getter = do st <- get
                 return (getter st)

liftIO :: IO a -> Comp a
liftIO ioA = Comp $ \s -> do a <- ioA
                             return (a,s)

type NoRecomp result = ModIface -> Comp result
type FrontEnd core = Comp (Maybe core)

-- FIXME: The old interface and module index are only using in 'batch' and
David Himmelstrup's avatar
David Himmelstrup committed
229
--        'interactive' mode. They should be removed from 'oneshot' mode.
230
231
232
233
234
235
236
237
type Compiler result =  HscEnv
                     -> ModSummary
                     -> Bool                -- True <=> source unchanged
                     -> Maybe ModIface      -- Old interface, if available
                     -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                     -> IO (Maybe result)


238
-- This functions checks if recompilation is necessary and
239
-- then combines the FrontEnd and BackEnd to a working compiler.
240
hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
241
              -> (Maybe (Int,Int) -> Bool -> Comp ())
242
              -> FrontEnd core
243
              -> (core -> Comp result)   -- Backend.
244
              -> Compiler result
245
hscMkCompiler norecomp messenger frontend backend
246
              hsc_env mod_summary source_unchanged
247
              mbOldIface mbModIndex
248
249
    = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
      do (recomp_reqd, mbCheckedIface)
250
             <- {-# SCC "checkOldIface" #-}
251
                liftIO $ checkOldIface hsc_env mod_summary
252
253
254
                              source_unchanged mbOldIface
         case mbCheckedIface of 
           Just iface | not recomp_reqd
255
256
               -> do messenger mbModIndex False
                     result <- norecomp iface
257
258
                     return (Just result)
           _otherwise
259
260
               -> do messenger mbModIndex True
                     mbCore <- frontend
261
262
263
264
                     case mbCore of
                       Nothing
                           -> return Nothing
                       Just core
265
                           -> do result <- backend core
266
267
                                 return (Just result)

268
269
270
271
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------

272
--        1         2         3         4         5         6         7         8          9
273
274
275
276
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
hscCompileOneShot hsc_env mod_summary =
    compiler hsc_env mod_summary
277
278
279
280
281
    where mkComp = hscMkCompiler (norecompOneShot HscNoRecomp) oneShotMsg
          -- How to compile nonBoot files.
          nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
                            hscWriteIface >>= hscOneShot
          -- How to compile boot files.
282
          bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False)
283
284
285
          compiler
              = case ms_hsc_src mod_summary of
                ExtCoreFile
286
                    -> mkComp hscCoreFrontEnd nonBootComp
287
                HsSrcFile
288
                    -> mkComp hscFileFrontEnd nonBootComp
289
                HsBootFile
290
                    -> mkComp hscFileFrontEnd bootComp
291

292
293
294
-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileBatch hsc_env mod_summary
295
    = compiler hsc_env mod_summary
296
297
298
    where mkComp = hscMkCompiler norecompBatch (batchMsg False)
          nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
                            hscWriteIface >>= hscBatch
299
          bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
300
301
302
          compiler
              = case ms_hsc_src mod_summary of
                ExtCoreFile
303
                    -> mkComp hscCoreFrontEnd nonBootComp
304
                HsSrcFile
305
                    -> mkComp hscFileFrontEnd nonBootComp
306
                HsBootFile
307
                    -> mkComp hscFileFrontEnd bootComp
308

309
310
311
312
313
-- Type-check Haskell, boot and extCore.
hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileNothing hsc_env mod_summary
    = compiler hsc_env mod_summary
    where mkComp = hscMkCompiler norecompBatch (batchMsg False)
314
          pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing
315
316
317
          compiler
              = case ms_hsc_src mod_summary of
                ExtCoreFile
318
                    -> mkComp hscCoreFrontEnd pipeline
319
                HsSrcFile
320
                    -> mkComp hscFileFrontEnd pipeline
321
                HsBootFile
322
                    -> mkComp hscFileFrontEnd pipeline
323
324
325
326

-- Compile Haskell, extCore to bytecode.
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
hscCompileInteractive hsc_env mod_summary =
327
328
    hscMkCompiler norecompInteractive (batchMsg True)
                  frontend backend
329
                  hsc_env mod_summary
330
331
    where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
          frontend = case ms_hsc_src mod_summary of
332
333
334
335
                       ExtCoreFile -> hscCoreFrontEnd
                       HsSrcFile   -> hscFileFrontEnd
                       HsBootFile  -> panic bootErrorMsg
          bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
336
                         "Use 'hscCompileBatch' instead."
337

338
339
340
341
--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------

342
norecompOneShot :: a -> NoRecomp a
343
344
345
norecompOneShot a old_iface
    = do hsc_env <- gets compHscEnv
         liftIO $ do
346
347
348
         dumpIfaceStats hsc_env
         return a

349
350
norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
norecompBatch = norecompWorker HscNoRecomp False
351
352

norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
353
norecompInteractive = norecompWorker InteractiveNoRecomp True
354

355
norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
356
357
358
359
norecompWorker a isInterp old_iface
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         liftIO $ do
360
361
362
363
364
365
         new_details <- {-# SCC "tcRnIface" #-}
                        initIfaceCheck hsc_env $
                        typecheckIface old_iface
         dumpIfaceStats hsc_env
         return (a, old_iface, new_details)

366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
--------------------------------------------------------------
-- Progress displayers.
--------------------------------------------------------------

oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp ()
oneShotMsg _mb_mod_index recomp
    = do hsc_env <- gets compHscEnv
         liftIO $ do
         if recomp
            then return ()
            else compilationProgressMsg (hsc_dflags hsc_env) $
                     "compilation IS NOT required"

batchMsg :: Bool -> Maybe (Int,Int) -> Bool -> Comp ()
batchMsg toInterp mb_mod_index recomp
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
                           (showModuleIndex mb_mod_index ++
                            msg ++ showModMsg (not toInterp) mod_summary)
         liftIO $ do
         if recomp
            then showMsg "Compiling "
            else showMsg "Skipping  "



393
394
395
396
397
--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------

hscCoreFrontEnd :: FrontEnd ModGuts
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
hscCoreFrontEnd =
    do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       liftIO $ do
            -------------------
            -- PARSE
            -------------------
       inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
       case parseCore inp 1 of
         FailP s
             -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
                   return Nothing
         OkP rdr_module
             -------------------
             -- RENAME and TYPECHECK
             -------------------
             -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
                                                 tcRnExtCore hsc_env rdr_module
                   printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
                   case maybe_tc_result of
                     Nothing       -> return Nothing
                     Just mod_guts -> return (Just mod_guts)         -- No desugaring to do!
420

421
422
	 
hscFileFrontEnd :: FrontEnd ModGuts
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
hscFileFrontEnd =
    do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       liftIO $ do
             -------------------
             -- PARSE
             -------------------
       let dflags = hsc_dflags hsc_env
           hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
           hspp_buf  = ms_hspp_buf  mod_summary
       maybe_parsed <- myParseModule dflags hspp_file hspp_buf
       case maybe_parsed of
         Left err
             -> do printBagOfErrors dflags (unitBag err)
                   return Nothing
         Right rdr_module
             -------------------
             -- RENAME and TYPECHECK
             -------------------
             -> do (tc_msgs, maybe_tc_result) 
                       <- {-# SCC "Typecheck-Rename" #-}
                          tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
                   printErrorsAndWarnings dflags tc_msgs
                   case maybe_tc_result of
                     Nothing
                         -> return Nothing
                     Just tc_result
                         -------------------
                         -- DESUGAR
                         -------------------
                         -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
                                                           deSugar hsc_env tc_result
                               printBagOfWarnings dflags warns
                               return maybe_ds_result
457

458
459
460
--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------
461

462
463
464
465
466
467
468
469
470
471
472
473
hscSimplify :: ModGuts -> Comp ModGuts
hscSimplify ds_result
  = do hsc_env <- gets compHscEnv
       liftIO $ do
       flat_result <- {-# SCC "Flattening" #-}
                      flatten hsc_env ds_result
           -------------------
           -- SIMPLIFY
           -------------------
       simpl_result <- {-# SCC "Core2Core" #-}
                       core2core hsc_env flat_result
       return simpl_result
474
475

--------------------------------------------------------------
476
-- Interface generators
477
478
--------------------------------------------------------------

479
480
481
-- HACK: we return ModGuts even though we know it's not gonna be used.
--       We do this because the type signature needs to be identical
--       in structure to the type of 'hscNormalIface'.
482
483
hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
hscSimpleIface ds_result
484
485
486
487
488
  = do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       maybe_old_iface <- gets compOldIface
       liftIO $ do
       details <- mkBootModDetails hsc_env ds_result
489
490
491
492
493
       (new_iface, no_change) 
           <- {-# SCC "MkFinalIface" #-}
              mkIface hsc_env maybe_old_iface ds_result details
       -- And the answer is ...
       dumpIfaceStats hsc_env
494
495
496
497
498
499
500
501
       return (new_iface, no_change, details, ds_result)

hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface simpl_result
  = do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       maybe_old_iface <- gets compOldIface
       liftIO $ do
502
503
504
 	    -------------------
 	    -- TIDY
 	    -------------------
505
506
       (cg_guts, details) <- {-# SCC "CoreTidy" #-}
                             tidyProgram hsc_env simpl_result
507
508
509
510
511
512
513

 	    -------------------
	    -- BUILD THE NEW ModIface and ModDetails
	    --	and emit external core if necessary
	    -- This has to happen *after* code gen so that the back-end
	    -- info has been set.  Not yet clear if it matters waiting
	    -- until after code output
514
       (new_iface, no_change)
515
516
517
		<- {-# SCC "MkFinalIface" #-}
		   mkIface hsc_env maybe_old_iface simpl_result details
	-- Emit external core
518
       emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006
519
520
521

 	    -------------------
 	    -- Return the prepared code.
522
       return (new_iface, no_change, details, cg_guts)
523

524
--------------------------------------------------------------
525
-- BackEnd combinators
526
527
--------------------------------------------------------------

528
529
530
531
532
533
534
535
536
537
538
539
hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
hscWriteIface (iface, no_change, details, a)
    = do mod_summary <- gets compModSummary
         liftIO $ do
         unless no_change
           $ writeIfaceFile (ms_location mod_summary) iface
         return (iface, details, a)

hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
hscIgnoreIface (iface, no_change, details, a)
    = return (iface, details, a)

540
-- Don't output any code.
541
542
hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
hscNothing (iface, details, a)
543
    = return (HscRecomp False, iface, details)
544
545

-- Generate code and return both the new ModIface and the ModDetails.
546
547
548
hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
hscBatch (iface, details, cgguts)
    = do hasStub <- hscCompile cgguts
549
         return (HscRecomp hasStub, iface, details)
550
551

-- Here we don't need the ModIface and ModDetails anymore.
552
553
554
hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
hscOneShot (_, _, cgguts)
    = do hasStub <- hscCompile cgguts
555
         return (HscRecomp hasStub)
556

557
558
559
560
561
562
563
-- Compile to hard-code.
hscCompile :: CgGuts -> Comp Bool
hscCompile cgguts
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         liftIO $ do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
                     cg_dir_imps = dir_imps,
                     cg_foreign  = foreign_stubs,
                     cg_home_mods = home_mods,
                     cg_dep_pkgs = dependencies } = cgguts
             dflags = hsc_dflags hsc_env
             location = ms_location mod_summary
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
             -- but we don't generate any code for newtypes

         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
                        corePrepPgm dflags core_binds data_tycons ;
         -----------------  Convert to STG ------------------
         (stg_binds, cost_centre_info)
             <- {-# SCC "CoreToStg" #-}
                myCoreToStg dflags home_mods this_mod prepd_binds	
         ------------------  Code generation ------------------
         abstractC <- {-# SCC "CodeGen" #-}
                      codeGen dflags home_mods this_mod data_tycons
                              foreign_stubs dir_imps cost_centre_info
                              stg_binds
         ------------------  Code output -----------------------
         (stub_h_exists,stub_c_exists)
             <- codeOutput dflags this_mod location foreign_stubs 
                dependencies abstractC
         return stub_c_exists

598
599
hscConst :: b -> a -> Comp b
hscConst b a = return b
600

601
602
603
hscInteractive :: (ModIface, ModDetails, CgGuts)
               -> Comp (InteractiveStatus, ModIface, ModDetails)
hscInteractive (iface, details, cgguts)
604
#ifdef GHCI
605
606
607
608
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         liftIO $ do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
609
610
611
612
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
613
                     cg_foreign  = foreign_stubs } = cgguts
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
             dflags = hsc_dflags hsc_env
             location = ms_location mod_summary
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
             -- but we don't generate any code for newtypes

         -------------------
         -- PREPARE FOR CODE GENERATION
         -- Do saturation and convert to A-normal form
         prepd_binds <- {-# SCC "CorePrep" #-}
                        corePrepPgm dflags core_binds data_tycons ;
         -----------------  Generate byte code ------------------
         comp_bc <- byteCodeGen dflags prepd_binds data_tycons
         ------------------ Create f-x-dynamic C-side stuff ---
         (istub_h_exists, istub_c_exists) 
             <- outputForeignStubs dflags this_mod location foreign_stubs
         return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
#else
    = panic "GHC not compiled with interpreter"
#endif

635
636
------------------------------

637
hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
638
hscFileCheck hsc_env mod_summary = do {
639
640
641
 	    -------------------
 	    -- PARSE
 	    -------------------
642
643
	; let dflags    = hsc_dflags hsc_env
	      hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
644
645
	      hspp_buf  = ms_hspp_buf  mod_summary

646
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
647
648

	; case maybe_parsed of {
649
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
650
			    ; return Nothing } ;
651
652
653
654
655
656
657
      	     Right rdr_module -> do {

 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
		<- _scc_ "Typecheck-Rename" 
658
659
660
		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
			True{-save renamed syntax-}
			rdr_module
661

662
	; printErrorsAndWarnings dflags tc_msgs
663
	; case maybe_tc_result of {
664
      	     Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
665
666
667
668
669
670
      	     Just tc_result -> do
		let md = ModDetails { 
				md_types   = tcg_type_env tc_result,
				md_exports = tcg_exports  tc_result,
				md_insts   = tcg_insts    tc_result,
				md_rules   = [panic "no rules"] }
671
				   -- Rules are CoreRules, not the
672
				   -- RuleDecls we get out of the typechecker
673
674
675
676
                    rnInfo = do decl <- tcg_rn_decls tc_result
                                imports <- tcg_rn_imports tc_result
                                let exports = tcg_rn_exports tc_result
                                return (decl,imports,exports)
677
		return (Just (HscChecked rdr_module 
678
                                   rnInfo
679
680
				   (Just (tcg_binds tc_result,
					  tcg_rdr_env tc_result,
681
					  md))))
682
	}}}}
683

684

685
686
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
687
  maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
688
689
690
  case maybe_cmm of
    Nothing -> return False
    Just cmm -> do
691
	codeOutput dflags no_mod no_loc NoStubs [] [cmm]
692
693
694
	return True
  where
	no_mod = panic "hscCmmFile: no_mod"
695
696
697
	no_loc = ModLocation{ ml_hs_file  = Just filename,
                              ml_hi_file  = panic "hscCmmFile: no hi file",
                              ml_obj_file = panic "hscCmmFile: no obj file" }
698
699


700
myParseModule dflags src_filename maybe_src_buf
701
702
703
 =    --------------------------  Parser  ----------------
      showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
704
705
706
707
708
709
710

	-- sometimes we already have the buffer in memory, perhaps
	-- because we needed to parse the imports out of it, or get the 
	-- module name.
      buf <- case maybe_src_buf of
		Just b  -> return b
		Nothing -> hGetStringBuffer src_filename
711

712
      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
713

714
      case unP parseModule (mkPState buf loc dflags) of {
715

716
	PFailed span err -> return (Left (mkPlainErrMsg span err));
717

718
	POk _ rdr_module -> do {
719

720
721
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
722
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
723
724
			   (ppSourceStats False rdr_module) ;
      
725
      return (Right rdr_module)
726
	-- ToDo: free the string buffer later.
727
      }}
728
729


730
myCoreToStg dflags home_mods this_mod prepd_binds
731
 = do 
732
      stg_binds <- {-# SCC "Core2Stg" #-}
733
	     coreToStg home_mods prepd_binds
734

735
      (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
736
	     stg2stg dflags home_mods this_mod stg_binds
737

738
      return (stg_binds2, cost_centre_info)
739
740
\end{code}

741

742
743
%************************************************************************
%*									*
744
\subsection{Compiling a do-statement}
745
746
747
%*									*
%************************************************************************

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
When the UnlinkedBCOExpr is linked you get an HValue of type
	IO [HValue]
When you run it you get a list of HValues that should be 
the same length as the list of names; add them to the ClosureEnv.

A naked expression returns a singleton Name [it].

	What you type			The IO [HValue] that hscStmt returns
	-------------			------------------------------------
	let pat = expr		==> 	let pat = expr in return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]

	pat <- expr		==> 	expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
					bindings: [x,y,...]

	expr (of IO type)	==>	expr >>= \ v -> return [v]
	  [NB: result not printed]	bindings: [it]
	  

	expr (of non-IO type, 
	  result showable)	==>	let v = expr in print v >> return [v]
	  				bindings: [it]
770

771
772
773
774
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
775
776
777
778
#ifdef GHCI
hscStmt		-- Compile a stmt all the way to an HValue, but don't run it
  :: HscEnv
  -> String			-- The statement
779
  -> IO (Maybe (HscEnv, [Name], HValue))
chak's avatar
chak committed
780

781
hscStmt hsc_env stmt
782
783
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
	; case maybe_stmt of {
784
785
786
      	     Nothing	  -> return Nothing ;	-- Parse error
      	     Just Nothing -> return Nothing ;	-- Empty line
      	     Just (Just parsed_stmt) -> do {	-- The real stuff
787

788
		-- Rename and typecheck it
789
790
	  let icontext = hsc_IC hsc_env
	; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
791

792
	; case maybe_tc_result of {
793
		Nothing -> return Nothing ;
794
		Just (new_ic, bound_names, tc_expr) -> do {
795

796
		-- Then desugar, code gen, and link it
797
	; hval <- compileExpr hsc_env iNTERACTIVE 
798
799
800
			      (ic_rn_gbl_env new_ic) 
			      (ic_type_env new_ic)
			      tc_expr
801

802
	; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
803
	}}}}}
804

805
806
807
hscTcExpr	-- Typecheck an expression (but don't run it)
  :: HscEnv
  -> String			-- The expression
808
  -> IO (Maybe Type)
809

810
hscTcExpr hsc_env expr
811
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
812
	; let icontext = hsc_IC hsc_env
813
	; case maybe_stmt of {
814
	     Nothing      -> return Nothing ;	-- Parse error
815
	     Just (Just (L _ (ExprStmt expr _ _)))
816
			-> tcRnExpr hsc_env icontext expr ;
817
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
818
			        return Nothing } ;
819
820
821
822
823
824
825
      	     } }

hscKcType	-- Find the kind of a type
  :: HscEnv
  -> String			-- The type
  -> IO (Maybe Kind)

826
hscKcType hsc_env str
827
  = do	{ maybe_type <- hscParseType (hsc_dflags hsc_env) str
828
	; let icontext = hsc_IC hsc_env
829
830
	; case maybe_type of {
	     Just ty	-> tcRnType hsc_env icontext ty ;
831
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
832
			        return Nothing } ;
833
      	     Nothing    -> return Nothing } }
834
#endif
835
\end{code}
836

837
\begin{code}
838
#ifdef GHCI
839
840
841
842
843
hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
hscParseStmt = hscParseThing parseStmt

hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
hscParseType = hscParseThing parseType
844
#endif
845
846
847
848
849
850
851
852
853
854
855

hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
hscParseIdentifier = hscParseThing parseIdentifier

hscParseThing :: Outputable thing
	      => Lexer.P thing
	      -> DynFlags -> String
	      -> IO (Maybe thing)
	-- Nothing => Parse error (message already printed)
	-- Just x  => success
hscParseThing parser dflags str
856
857
 = showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
858

859
      buf <- stringToStringBuffer str
860

861
      let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
862

863
      case unP parser (mkPState buf loc dflags) of {
864

865
866
	PFailed span err -> do { printError span err;
                                 return Nothing };
867

868
	POk _ thing -> do {
869

870
871
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
872
873
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
      return (Just thing)
874
875
      }}
\end{code}
876

877
878
%************************************************************************
%*									*
879
	Desugar, simplify, convert to bytecode, and link an expression
880
881
882
883
884
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
885
compileExpr :: HscEnv 
886
	    -> Module -> GlobalRdrEnv -> TypeEnv
887
	    -> LHsExpr Id
888
	    -> IO HValue
889

890
compileExpr hsc_env this_mod rdr_env type_env tc_expr
891
892
893
  = do	{ let { dflags  = hsc_dflags hsc_env ;
		lint_on = dopt Opt_DoCoreLinting dflags }
	      
894
	 	-- Desugar it
895
	; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
896
897
	
		-- Flatten it
898
	; flat_expr <- flattenExpr hsc_env ds_expr
899

900
901
		-- Simplify it
	; simpl_expr <- simplifyExpr dflags flat_expr
902

903
		-- Tidy it (temporary, until coreSat does cloning)
904
	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
905

906
907
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
908

909
910
911
912
913
914
915
916
917
		-- Lint if necessary
		-- ToDo: improve SrcLoc
	; if lint_on then 
		case lintUnfolding noSrcLoc [] prepd_expr of
		   Just err -> pprPanic "compileExpr" err
		   Nothing  -> return ()
	  else
		return ()

918
919
		-- Convert to BCOs
	; bcos <- coreExprToBCOs dflags prepd_expr
920

921
		-- link it
922
	; hval <- linkExpr hsc_env bcos
923

924
925
	; return hval
     }
926
927
928
#endif
\end{code}

929

930
931
%************************************************************************
%*									*
932
	Statistics on reading interfaces
933
934
935
936
%*									*
%************************************************************************

\begin{code}
937
938
939
940
941
942
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
  = do	{ eps <- readIORef (hsc_EPS hsc_env)
	; dumpIfSet (dump_if_trace || dump_rn_stats)
	      	    "Interface statistics"
	      	    (ifaceStats eps) }
943
  where
944
945
946
    dflags = hsc_dflags hsc_env
    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
    dump_if_trace = dopt Opt_D_dump_if_trace dflags
947
\end{code}
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963

%************************************************************************
%*									*
	Progress Messages: Module i of n
%*									*
%************************************************************************

\begin{code}
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
    where
        n_str = show n
        i_str = show i
        padded = replicate (length n_str - length i_str) ' ' ++ i_str
\end{code}