HscMain.lhs 36.6 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(..), LStmt, LHsType )
29
30
31
import CodeOutput	( outputForeignStubs )
import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
import Linker		( HValue, linkExpr )
32
import CoreTidy		( tidyExpr )
33
import CorePrep		( corePrepExpr )
34
import Flattening	( flattenExpr )
35
36
import Desugar          ( deSugarExpr )
import SimplCore        ( simplifyExpr )
37
import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
38
39
import Type		( Type )
import PrelNames	( iNTERACTIVE )
40
import {- Kind parts of -} Type		( Kind )
41
import CoreLint		( lintUnfolding )
42
import DsMeta		( templateHaskellNames )
43
import SrcLoc		( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
44
import VarSet
45
import VarEnv		( emptyTidyEnv )
46
47
#endif

48
import Var		( Id )
49
import Module		( emptyModuleEnv, ModLocation(..), Module )
50
import RdrName		( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
51
52
import HsSyn		( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
                          HaddockModInfo )
53
import CoreSyn
54
import SrcLoc		( Located(..) )
Ian Lynagh's avatar
Ian Lynagh committed
55
import StringBuffer
56
import Parser
57
import Lexer
58
import SrcLoc		( mkSrcLoc )
59
60
import TcRnDriver	( tcRnModule, tcRnExtCore )
import TcIface		( typecheckIface )
61
import TcRnMonad	( initIfaceCheck, TcGblEnv(..) )
62
63
64
import IfaceEnv		( initNameCache )
import LoadIface	( ifaceStats, initExternalPackageState )
import PrelInfo		( wiredInThings, basicKnownKeyNames )
65
import MkIface		( checkOldIface, mkIface, writeIfaceFile )
66
import Desugar          ( deSugar )
67
import SimplCore        ( core2core )
68
import TidyPgm		( tidyProgram, mkBootModDetails )
69
import CorePrep		( corePrepPgm )
70
import CoreToStg	( coreToStg )
71
72
import StgSyn
import CostCentre
73
import TyCon		( isDataTyCon )
74
import Name		( Name, NamedThing(..) )
75
76
import SimplStg		( stg2stg )
import CodeGen		( codeGen )
77
import Cmm              ( Cmm )
78
import CmmParse		( parseCmmFile )
79
import CmmCPS
80
import CmmCPSZ
81
import CmmInfo
82
83
84
import CmmCvt
import CmmTx
import CmmContFlowOpt
85
import CodeOutput	( codeOutput )
86
import NameEnv          ( emptyNameEnv )
87

88
import DynFlags
89
import ErrUtils
90
import UniqSupply	( mkSplitUniqSupply )
91

92
import Outputable
93
import HscStats		( ppSourceStats )
94
import HscTypes
95
96
97
import MkExternalCore	( emitExternalCore )
import ParserCore
import ParserCoreUtils
98
import FastString
Simon Marlow's avatar
Simon Marlow committed
99
import UniqFM		( emptyUFM )
100
import UniqSupply       ( initUs_ )
101
import Bag		( unitBag )
Simon Marlow's avatar
Simon Marlow committed
102
103

import Control.Monad
104
import System.Exit
Simon Marlow's avatar
Simon Marlow committed
105
106
import System.IO
import Data.IORef
107
108
\end{code}

109
110
111

%************************************************************************
%*									*
112
113
114
115
116
		Initialisation
%*									*
%************************************************************************

\begin{code}
117
118
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags
119
120
121
  = do 	{ eps_var <- newIORef initExternalPackageState
	; us      <- mkSplitUniqSupply 'r'
	; nc_var  <- newIORef (initNameCache us knownKeyNames)
Simon Marlow's avatar
Simon Marlow committed
122
123
	; fc_var  <- newIORef emptyUFM
	; mlc_var  <- newIORef emptyModuleEnv
124
	; return (HscEnv { hsc_dflags = dflags,
125
126
127
			   hsc_targets = [],
			   hsc_mod_graph = [],
			   hsc_IC     = emptyInteractiveContext,
128
129
			   hsc_HPT    = emptyHomePackageTable,
			   hsc_EPS    = eps_var,
130
			   hsc_NC     = nc_var,
131
			   hsc_FC     = fc_var,
Simon Marlow's avatar
Simon Marlow committed
132
			   hsc_MLC    = mlc_var,
133
134
                           hsc_global_rdr_env = emptyGlobalRdrEnv,
                           hsc_global_type_env = emptyNameEnv } ) }
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
			

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
150
151
152
%*									*
%************************************************************************

153
154
155
156
157
158
159
160
161
                   --------------------------------
                        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).
162
163
164
165
166
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.
167
168
169
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
170
171
172
173
174
175
176
177
178
179
180
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.

181
182
183
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.

184
\begin{code}
185

186
187
data HscChecked
    = HscChecked
188
        -- parsed
189
        (Located (HsModule RdrName))
190
        -- renamed
191
192
        (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
                Maybe (HsDoc Name), HaddockModInfo Name))
193
        -- typechecked
194
        (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
195
196
        -- desugared
        (Maybe [CoreBind])
197

198
-- Status of a compilation to hard-code or nothing.
199
data HscStatus
200
201
202
203
204
    = 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
David Himmelstrup's avatar
David Himmelstrup committed
205
                      -- them for us.
206
207

-- Status of a compilation to byte-code.
208
209
210
211
data InteractiveStatus
    = InteractiveNoRecomp
    | InteractiveRecomp Bool     -- Same as HscStatus
                        CompiledByteCode
212
                        ModBreaks
213
214


215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
-- 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)

Simon Marlow's avatar
Simon Marlow committed
237
238
239
modify :: (CompState -> CompState) -> Comp ()
modify f = Comp $ \s -> return ((), f s)

240
241
242
243
244
245
246
247
248
249
250
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

-- FIXME: The old interface and module index are only using in 'batch' and
David Himmelstrup's avatar
David Himmelstrup committed
251
--        'interactive' mode. They should be removed from 'oneshot' mode.
252
253
254
255
256
257
258
259
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)


260
-- This functions checks if recompilation is necessary and
261
-- then combines the FrontEnd and BackEnd to a working compiler.
262
hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
263
              -> (Maybe (Int,Int) -> Bool -> Comp ())
264
265
              -> Comp (Maybe ModGuts)       -- Front end
              -> (ModGuts -> Comp result)   -- Backend.
266
              -> Compiler result
267
hscMkCompiler norecomp messenger frontend backend
268
              hsc_env mod_summary source_unchanged
269
              mbOldIface mbModIndex
270
271
    = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
      do (recomp_reqd, mbCheckedIface)
272
             <- {-# SCC "checkOldIface" #-}
273
                liftIO $ checkOldIface hsc_env mod_summary
274
                              source_unchanged mbOldIface
Simon Marlow's avatar
Simon Marlow committed
275
276
277
278
	 -- save the interface that comes back from checkOldIface.
	 -- In one-shot mode we don't have the old iface until this
	 -- point, when checkOldIface reads it from the disk.
	 modify (\s -> s{ compOldIface = mbCheckedIface })
279
280
         case mbCheckedIface of 
           Just iface | not recomp_reqd
281
282
               -> do messenger mbModIndex False
                     result <- norecomp iface
283
284
                     return (Just result)
           _otherwise
285
286
               -> do messenger mbModIndex True
                     mbCore <- frontend
287
288
289
290
                     case mbCore of
                       Nothing
                           -> return Nothing
                       Just core
291
                           -> do result <- backend core
292
293
                                 return (Just result)

294
295
296
297
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------

298
299
-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
Simon Marlow's avatar
Simon Marlow committed
300
301
302
303
304
hscCompileOneShot
   = hscCompiler norecompOneShot oneShotMsg backend boot_backend
   where
     backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
     boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (HscRecomp False)
305

306
307
-- Compile Haskell, boot and extCore in batch mode.
hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
Simon Marlow's avatar
Simon Marlow committed
308
309
310
311
312
hscCompileBatch
   = hscCompiler norecompBatch batchMsg backend boot_backend
   where
     backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch
     boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
313

314
-- Type-check Haskell, boot and extCore.
David Himmelstrup's avatar
David Himmelstrup committed
315
-- Does it make sense to compile extCore to nothing?
316
hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
Simon Marlow's avatar
Simon Marlow committed
317
318
319
320
hscCompileNothing
   = hscCompiler norecompBatch batchMsg backend backend
   where
     backend inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing
321
322
323

-- Compile Haskell, extCore to bytecode.
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
Simon Marlow's avatar
Simon Marlow committed
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
hscCompileInteractive
   = hscCompiler norecompInteractive batchMsg backend boot_backend
   where
     backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
     boot_backend = panic "hscCompileInteractive: can't do boot files here"

hscCompiler
        :: NoRecomp result                                  -- No recomp necessary
        -> (Maybe (Int,Int) -> Bool -> Comp ())             -- Message callback
        -> (ModGuts -> Comp result)  -- Compile normal file
        -> (ModGuts -> Comp result) -- Compile boot file
        -> Compiler result
hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary =
    hscMkCompiler norecomp msg frontend backend hsc_env mod_summary
    where
          (frontend,backend)
              = case ms_hsc_src mod_summary of
                ExtCoreFile -> (hscCoreFrontEnd, nonBootComp)
                HsSrcFile   -> (hscFileFrontEnd, nonBootComp)
                HsBootFile  -> (hscFileFrontEnd, bootComp)
344

345
346
347
348
--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------

David Himmelstrup's avatar
David Himmelstrup committed
349
norecompOneShot :: NoRecomp HscStatus
350
norecompOneShot _old_iface
351
352
    = do hsc_env <- gets compHscEnv
         liftIO $ do
353
         dumpIfaceStats hsc_env
David Himmelstrup's avatar
David Himmelstrup committed
354
         return HscNoRecomp
355

356
357
norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
norecompBatch = norecompWorker HscNoRecomp False
358
359

norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
360
norecompInteractive = norecompWorker InteractiveNoRecomp True
361

362
norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
363
norecompWorker a _isInterp old_iface
364
    = do hsc_env <- gets compHscEnv
365
         _mod_summary <- gets compModSummary
366
         liftIO $ do
367
368
369
370
371
372
         new_details <- {-# SCC "tcRnIface" #-}
                        initIfaceCheck hsc_env $
                        typecheckIface old_iface
         dumpIfaceStats hsc_env
         return (a, old_iface, new_details)

373
374
375
376
377
378
379
380
381
382
383
384
385
--------------------------------------------------------------
-- 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"

386
387
batchMsg :: Maybe (Int,Int) -> Bool -> Comp ()
batchMsg mb_mod_index recomp
388
389
390
391
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
                           (showModuleIndex mb_mod_index ++
392
                            msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
393
394
395
         liftIO $ do
         if recomp
            then showMsg "Compiling "
396
            else if verbosity (hsc_dflags hsc_env) >= 2
397
398
                    then showMsg "Skipping  "
                    else return ()
399

400
401
402
403
--------------------------------------------------------------
-- FrontEnds
--------------------------------------------------------------

404
hscCoreFrontEnd :: Comp (Maybe ModGuts)
405
406
407
408
409
410
411
hscCoreFrontEnd =
    do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       liftIO $ do
            -------------------
            -- PARSE
            -------------------
412
       inp <- readFile (ms_hspp_file mod_summary)
413
414
415
416
417
418
419
420
421
422
423
424
425
426
       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!
427

428
	 
429
hscFileFrontEnd :: Comp (Maybe ModGuts)
430
431
432
433
434
435
436
437
hscFileFrontEnd =
    do hsc_env <- gets compHscEnv
       mod_summary <- gets compModSummary
       liftIO $ do
             -------------------
             -- PARSE
             -------------------
       let dflags = hsc_dflags hsc_env
438
           hspp_file = ms_hspp_file mod_summary
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
           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
                         -------------------
andy@galois.com's avatar
andy@galois.com committed
460
                         -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result
461

462
463
464
--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------
465

466
467
468
469
470
471
472
473
hscSimplify :: ModGuts -> Comp ModGuts
hscSimplify ds_result
  = do hsc_env <- gets compHscEnv
       liftIO $ do
           -------------------
           -- SIMPLIFY
           -------------------
       simpl_result <- {-# SCC "Core2Core" #-}
474
                       core2core hsc_env ds_result
475
       return simpl_result
476
477

--------------------------------------------------------------
478
-- Interface generators
479
480
--------------------------------------------------------------

481
482
483
-- 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'.
484
485
hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
hscSimpleIface ds_result
486
  = do hsc_env <- gets compHscEnv
487
       _mod_summary <- gets compModSummary
488
489
490
       maybe_old_iface <- gets compOldIface
       liftIO $ do
       details <- mkBootModDetails hsc_env ds_result
491
492
493
494
495
       (new_iface, no_change) 
           <- {-# SCC "MkFinalIface" #-}
              mkIface hsc_env maybe_old_iface ds_result details
       -- And the answer is ...
       dumpIfaceStats hsc_env
496
497
498
499
500
       return (new_iface, no_change, details, ds_result)

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

 	    -------------------
	    -- 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
516
       (new_iface, no_change)
517
518
519
		<- {-# SCC "MkFinalIface" #-}
		   mkIface hsc_env maybe_old_iface simpl_result details
	-- Emit external core
520
       emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006
David Himmelstrup's avatar
David Himmelstrup committed
521
       dumpIfaceStats hsc_env
522
523
524

 	    -------------------
 	    -- Return the prepared code.
525
       return (new_iface, no_change, details, cg_guts)
526

527
--------------------------------------------------------------
528
-- BackEnd combinators
529
530
--------------------------------------------------------------

531
532
hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
hscWriteIface (iface, no_change, details, a)
533
    = do mod_summary <- gets compModSummary
534
535
         hsc_env <- gets compHscEnv
         let dflags = hsc_dflags hsc_env
536
         liftIO $ do
537
         unless no_change
538
           $ writeIfaceFile dflags (ms_location mod_summary) iface
539
540
541
         return (iface, details, a)

hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
542
hscIgnoreIface (iface, _no_change, details, a)
543
544
    = return (iface, details, a)

545
-- Don't output any code.
546
hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
547
hscNothing (iface, details, _)
548
    = return (HscRecomp False, iface, details)
549
550

-- Generate code and return both the new ModIface and the ModDetails.
551
552
553
hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
hscBatch (iface, details, cgguts)
    = do hasStub <- hscCompile cgguts
554
         return (HscRecomp hasStub, iface, details)
555
556

-- Here we don't need the ModIface and ModDetails anymore.
557
558
559
hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
hscOneShot (_, _, cgguts)
    = do hasStub <- hscCompile cgguts
560
         return (HscRecomp hasStub)
561

562
563
564
565
566
567
568
-- 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.
569
570
571
572
573
574
                     -- 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,
andy@galois.com's avatar
andy@galois.com committed
575
576
                     cg_dep_pkgs = dependencies,
		     cg_hpc_info = hpc_info } = cgguts
577
578
579
580
581
582
583
584
585
586
587
588
589
590
             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" #-}
Simon Marlow's avatar
Simon Marlow committed
591
                myCoreToStg dflags this_mod prepd_binds	
592
         ------------------  Code generation ------------------
593
         cmms <- {-# SCC "CodeGen" #-}
Simon Marlow's avatar
Simon Marlow committed
594
                      codeGen dflags this_mod data_tycons
595
                              dir_imps cost_centre_info
andy@galois.com's avatar
andy@galois.com committed
596
                              stg_binds hpc_info
597
598
599
         --- Optionally run experimental Cmm transformations ---
         cmms <- optionallyConvertAndOrCPS dflags cmms
                 -- ^ unless certain dflags are on, the identity function
600
         ------------------  Code output -----------------------
601
602
         rawcmms <- cmmToRawCmm cmms
         (_stub_h_exists, stub_c_exists)
603
             <- codeOutput dflags this_mod location foreign_stubs 
604
                dependencies rawcmms
605
606
         return stub_c_exists

607
608
hscInteractive :: (ModIface, ModDetails, CgGuts)
               -> Comp (InteractiveStatus, ModIface, ModDetails)
609
#ifdef GHCI
610
hscInteractive (iface, details, cgguts)
611
612
613
614
    = do hsc_env <- gets compHscEnv
         mod_summary <- gets compModSummary
         liftIO $ do
         let CgGuts{ -- This is the last use of the ModGuts in a compilation.
615
616
617
618
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
619
620
                     cg_foreign  = foreign_stubs,
                     cg_modBreaks = mod_breaks } = cgguts
621
622
623
624
625
626
627
628
629
630
631
632
             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 ------------------
633
         comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
634
         ------------------ Create f-x-dynamic C-side stuff ---
635
         (_istub_h_exists, istub_c_exists) 
636
             <- outputForeignStubs dflags this_mod location foreign_stubs
637
         return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)
638
#else
639
hscInteractive _ = panic "GHC not compiled with interpreter"
640
641
#endif

642
643
------------------------------

644
645
hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
hscFileCheck hsc_env mod_summary compileToCore = do {
646
647
648
 	    -------------------
 	    -- PARSE
 	    -------------------
649
	; let dflags    = hsc_dflags hsc_env
650
	      hspp_file = ms_hspp_file mod_summary
651
652
	      hspp_buf  = ms_hspp_buf  mod_summary

653
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
654
655

	; case maybe_parsed of {
656
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
657
			    ; return Nothing } ;
658
659
660
661
662
663
      	     Right rdr_module -> do {

 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
664
		<- {-# SCC "Typecheck-Rename" #-}
665
666
667
		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
			True{-save renamed syntax-}
			rdr_module
668

669
	; printErrorsAndWarnings dflags tc_msgs
670
	; case maybe_tc_result of {
671
      	     Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
672
      	     Just tc_result -> do
673
674
675
		let type_env = tcg_type_env tc_result
		    md = ModDetails { 
				md_types     = type_env,
676
677
678
				md_exports   = tcg_exports   tc_result,
				md_insts     = tcg_insts     tc_result,
				md_fam_insts = tcg_fam_insts tc_result,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
679
				md_rules     = [panic "no rules"],
680
				   -- Rules are CoreRules, not the
681
				   -- RuleDecls we get out of the typechecker
David Waern's avatar
David Waern committed
682
                                md_vect_info = noVectInfo
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
683
684
685
                                   -- VectInfo is added by the Core 
                                   -- vectorisation pass
                          }
686
687
688
                    rnInfo = do decl <- tcg_rn_decls tc_result
                                imports <- tcg_rn_imports tc_result
                                let exports = tcg_rn_exports tc_result
689
690
691
			        let doc = tcg_doc tc_result
				    hmi = tcg_hmi tc_result
                                return (decl,imports,exports,doc,hmi)
692
693
694
695
696
697
		maybeModGuts <- 
                 if compileToCore then
                   deSugar hsc_env (ms_location mod_summary) tc_result
                 else
                   return Nothing
                return (Just (HscChecked rdr_module 
698
                                   rnInfo
699
700
				   (Just (tcg_binds tc_result,
					  tcg_rdr_env tc_result,
701
702
					  md))
                                   (fmap mg_binds maybeModGuts)))
703
	}}}}
704

705

706
707
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
Simon Marlow's avatar
Simon Marlow committed
708
  maybe_cmm <- parseCmmFile dflags filename
709
710
711
  case maybe_cmm of
    Nothing -> return False
    Just cmm -> do
712
713
714
        cmms <- optionallyConvertAndOrCPS dflags [cmm]
        rawCmms <- cmmToRawCmm cmms
	codeOutput dflags no_mod no_loc NoStubs [] rawCmms
715
716
717
	return True
  where
	no_mod = panic "hscCmmFile: no_mod"
718
719
720
	no_loc = ModLocation{ ml_hs_file  = Just filename,
                              ml_hi_file  = panic "hscCmmFile: no hi file",
                              ml_obj_file = panic "hscCmmFile: no obj file" }
721

722
723
724
725
726
727
728
729
730
731
732
733
734
735
optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
optionallyConvertAndOrCPS dflags cmms =
    do   --------  Optionally convert to and from zipper ------
       cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
               then mapM (testCmmConversion dflags) cmms
               else return cmms
         ---------  Optionally convert to CPS (MDA) -----------
       cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
                  dopt Opt_RunCPSZ dflags
               then cmmCPS dflags cmms
               else return cmms
       return cmms


736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
testCmmConversion :: DynFlags -> Cmm -> IO Cmm
testCmmConversion dflags cmm =
    do showPass dflags "CmmToCmm"
       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
       --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
       us <- mkSplitUniqSupply 'C'
       let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
       let cvtm = do g <- cmmToZgraph cmm
                     return $ cfopts g
       let zgraph = initUs_ us cvtm
       cps_zgraph <- protoCmmCPSZ dflags zgraph
       let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
       dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
       showPass dflags "Convert from Z back to Cmm"
       let cvt = cmmOfZgraph $ cfopts $ chosen_graph
       dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
       return cvt
       -- return cmm -- don't use the conversion
754

Ian Lynagh's avatar
Ian Lynagh committed
755
756
myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
              -> IO (Either ErrMsg (Located (HsModule RdrName)))
757
myParseModule dflags src_filename maybe_src_buf
758
759
760
 =    --------------------------  Parser  ----------------
      showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
761
762
763
764
765
766
767

	-- 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
768

769
      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
770

771
      case unP parseModule (mkPState buf loc dflags) of {
772

773
	PFailed span err -> return (Left (mkPlainErrMsg span err));
774

775
	POk pst rdr_module -> do {
776

777
778
779
780
      let {ms = getMessages pst};
      printErrorsAndWarnings dflags ms;
      when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
      
781
782
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
783
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
784
785
			   (ppSourceStats False rdr_module) ;
      
786
      return (Right rdr_module)
787
	-- ToDo: free the string buffer later.
788
      }}
789
790


791
792
793
794
myCoreToStg :: DynFlags -> Module -> [CoreBind]
            -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
	          , CollectedCCs) -- cost centre info (declared and used)

Simon Marlow's avatar
Simon Marlow committed
795
myCoreToStg dflags this_mod prepd_binds
796
 = do 
797
      stg_binds <- {-# SCC "Core2Stg" #-}
Simon Marlow's avatar
Simon Marlow committed
798
	     coreToStg (thisPackage dflags) prepd_binds
799

800
      (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
Simon Marlow's avatar
Simon Marlow committed
801
	     stg2stg dflags this_mod stg_binds
802

803
      return (stg_binds2, cost_centre_info)
804
805
\end{code}

806

807
808
%************************************************************************
%*									*
809
\subsection{Compiling a do-statement}
810
811
812
%*									*
%************************************************************************

813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
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]
835

836
837
838
839
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
840
841
842
843
#ifdef GHCI
hscStmt		-- Compile a stmt all the way to an HValue, but don't run it
  :: HscEnv
  -> String			-- The statement
844
  -> IO (Maybe ([Id], HValue))
chak's avatar
chak committed
845

846
hscStmt hsc_env stmt
847
848
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
	; case maybe_stmt of {
849
850
851
      	     Nothing	  -> return Nothing ;	-- Parse error
      	     Just Nothing -> return Nothing ;	-- Empty line
      	     Just (Just parsed_stmt) -> do {	-- The real stuff
852

853
		-- Rename and typecheck it
854
855
	  let icontext = hsc_IC hsc_env
	; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
856

857
	; case maybe_tc_result of {
858
		Nothing -> return Nothing ;
859
		Just (ids, tc_expr) -> do {
860
861

	 	-- Desugar it
862
863
	; let rdr_env  = ic_rn_gbl_env icontext
	      type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
864
865
866
867
868
869
	; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
	
	; case mb_ds_expr of {
		Nothing -> return Nothing ;
		Just ds_expr -> do {

870
		-- Then desugar, code gen, and link it
871
872
	; let src_span = srcLocSpan interactiveSrcLoc
	; hval <- compileExpr hsc_env src_span ds_expr
873

874
	; return (Just (ids, hval))
875
	}}}}}}}
876

877
878
879
hscTcExpr	-- Typecheck an expression (but don't run it)
  :: HscEnv
  -> String			-- The expression
880
  -> IO (Maybe Type)
881

882
hscTcExpr hsc_env expr
883
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
884
	; let icontext = hsc_IC hsc_env
885
	; case maybe_stmt of {
886
	     Nothing      -> return Nothing ;	-- Parse error
887
	     Just (Just (L _ (ExprStmt expr _ _)))
888
			-> tcRnExpr hsc_env icontext expr ;
889
	     Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
890
			        return Nothing } ;
891
892
893
894
895
896
897
      	     } }

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

898
hscKcType hsc_env str
899
  = do	{ maybe_type <- hscParseType (hsc_dflags hsc_env) str
900
	; let icontext = hsc_IC hsc_env
901
	; case maybe_type of {
902
903
	     Just ty -> tcRnType hsc_env icontext ty ;
      	     Nothing -> return Nothing } }
904
#endif
905
\end{code}
906

907
\begin{code}
908
#ifdef GHCI
909
910
911
912
913
hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
hscParseStmt = hscParseThing parseStmt

hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
hscParseType = hscParseThing parseType
914
#endif
915
916
917
918
919
920
921
922
923
924
925

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
926
927
 = showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
928

929
      buf <- stringToStringBuffer str
930

931
      let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
932

933
      case unP parser (mkPState buf loc dflags) of {
934

935
936
	PFailed span err -> do { printError span err;
                                 return Nothing };
937

938
939
940
941
942
	POk pst thing -> do {

      let {ms = getMessages pst};
      printErrorsAndWarnings dflags ms;
      when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
943

944
945
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
946
947
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
      return (Just thing)
948
949
      }}
\end{code}
950

951
952
%************************************************************************
%*									*
953
	Desugar, simplify, convert to bytecode, and link an expression
954
955
956
957
958
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
959
compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
960

961
compileExpr hsc_env srcspan ds_expr
962
  = do	{ let { dflags  = hsc_dflags hsc_env ;
963
		lint_on = dopt Opt_DoCoreLinting dflags }
964
	      
965
		-- Flatten it
966
	; flat_expr <- flattenExpr hsc_env ds_expr
967

968
969
		-- Simplify it
	; simpl_expr <- simplifyExpr dflags flat_expr
970

971
		-- Tidy it (temporary, until coreSat does cloning)
972
	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
973

974
975
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
976

977
978
979
		-- Lint if necessary
		-- ToDo: improve SrcLoc
	; if lint_on then 
980
981
982
983
                let ictxt = hsc_IC hsc_env
                    tyvars = varSetElems (ic_tyvars ictxt)
                in
		case lintUnfolding noSrcLoc tyvars prepd_expr of
984
985
986
987
988
		   Just err -> pprPanic "compileExpr" err
		   Nothing  -> return ()
	  else
		return ()

989
990
		-- Convert to BCOs
	; bcos <- coreExprToBCOs dflags prepd_expr
991

992
		-- link it
993
	; hval <- linkExpr hsc_env srcspan bcos
994

995
996
	; return hval
     }
997
998
999
#endif
\end{code}

1000

1001
1002
%************************************************************************
%*									*
1003
	Statistics on reading interfaces
1004
1005
1006
1007
%*									*
%************************************************************************

\begin{code}
1008
1009
1010
1011
1012
1013
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
  = do	{ eps <- readIORef (hsc_EPS hsc_env)
	; dumpIfSet (dump_if_trace || dump_rn_stats)
	      	    "Interface statistics"
	      	    (ifaceStats eps) }
1014
  where
1015
1016
1017
    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
1018
\end{code}
1019
1020
1021
1022
1023
1024
1025
1026

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

\begin{code}
1027
showModuleIndex :: Maybe (Int, Int) -> String
1028
1029
1030
1031
1032
1033
1034
1035
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}