HscMain.lhs 39.1 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
module HscMain ( 
9
	HscResult(..),
10
	hscMain, newHscEnv, hscCmmFile, 
11
	hscFileCheck,
12
	hscParseIdentifier,
13
#ifdef GHCI
14
15
	hscStmt, hscTcExpr, hscKcType,
	compileExpr,
16
#endif
17
18
19
20
21
          hscCompileOneShot     -- :: Compiler HscStatus
        , hscCompileMake        -- :: Compiler (HscStatus, ModIface, ModDetails)
        , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
        , HscStatus (..)
        , InteractiveStatus (..)
22
	) where
23

24
#include "HsVersions.h"
25

26
#ifdef GHCI
27
import HsSyn		( Stmt(..), LHsExpr, LStmt, LHsType )
28
import Module		( Module )
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
import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
36
37
import Type		( Type )
import PrelNames	( iNTERACTIVE )
38
import Kind		( Kind )
39
import CoreLint		( lintUnfolding )
40
import DsMeta		( templateHaskellNames )
41
import SrcLoc		( noSrcLoc )
42
import VarEnv		( emptyTidyEnv )
43
44
#endif

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

75
import DynFlags
76
import ErrUtils
77
import Util
78
import UniqSupply	( mkSplitUniqSupply )
79

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

95
96
97

%************************************************************************
%*									*
98
99
100
101
102
		Initialisation
%*									*
%************************************************************************

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

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
132
133
134
%*									*
%************************************************************************

135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
                   --------------------------------
                        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).
Compilation can happen in either 'one-shot', 'make', or 'interactive'
mode. 'One-shot' mode targets hard-code, 'make' mode targets hard-code
and nothing, and 'interactive' mode targets byte-code. The modes are
kept separate because of their different types.
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
when we discard the result. 'Make' mode is like 'one-shot' except that we
keep the resulting ModIface and ModDetails. 'Make' mode doesn't target
byte-code since that require us to return the newly compiled byte-code.
'Interactive' mode is similar to 'make' mode except that we return
the compiled byte-code together with the ModIface and ModDetails.
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.

159
\begin{code}
160
data HscResult
161
   -- Compilation failed
162
163
164
   = HscFail

   -- In IDE mode: we just do the static/dynamic checks
165
   | HscChecked 
166
167
168
169
170
171
        -- parsed
	(Located (HsModule RdrName))
        -- renamed
	(Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
        -- typechecked
	(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
172
173
174

   -- Concluded that it wasn't necessary
   | HscNoRecomp ModDetails  	         -- new details (HomeSymbolTable additions)
175
	         ModIface	         -- new iface (if any compilation was done)
176
177
178
179

   -- Did recompilation
   | HscRecomp   ModDetails  		-- new details (HomeSymbolTable additions)
                 ModIface		-- new iface (if any compilation was done)
180
181
	         Bool	 	 	-- stub_h exists
	         Bool  		 	-- stub_c exists
182
	         (Maybe CompiledByteCode)
183

184
185
186
187

-- What to do when we have compiler error or warning messages
type MessageAction = Messages -> IO ()

188
189
190
191
192
193
194
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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

--------------------------------------------------------------
-- Exterimental code start.
--------------------------------------------------------------

data HscStatus
    = NewHscNoRecomp
    | NewHscRecomp  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.

data InteractiveStatus
    = InteractiveNoRecomp
    | InteractiveRecomp Bool     -- Same as HscStatus
                        CompiledByteCode

type NoRecomp result = HscEnv -> ModSummary -> Bool -> ModIface -> Maybe (Int,Int) -> IO result
type FrontEnd core = HscEnv -> ModSummary -> Maybe (Int,Int) -> IO (Maybe core)
type BackEnd core prepCore = HscEnv -> ModSummary -> Maybe ModIface -> core -> IO prepCore
type CodeGen prepCore result = HscEnv -> ModSummary -> prepCore -> IO result

type Compiler result =  HscEnv
                     -> ModSummary
                     -> Bool                -- True <=> source unchanged
                     -> Bool                -- True <=> have an object file (for msgs only)
                     -> Maybe ModIface      -- Old interface, if available
                     -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                     -> IO (Maybe result)


hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
              -> FrontEnd core
              -> BackEnd core prepCore
              -> CodeGen prepCore result
              -> Compiler result
hscMkCompiler norecomp frontend backend codegen
              hsc_env mod_summary source_unchanged
              have_object mbOldIface mbModIndex
    = do (recomp_reqd, mbCheckedIface)
             <- {-# SCC "checkOldIface" #-}
                checkOldIface hsc_env mod_summary
                              source_unchanged mbOldIface
         case mbCheckedIface of 
           Just iface | not recomp_reqd
               -> do result <- norecomp hsc_env mod_summary have_object iface mbModIndex
                     return (Just result)
           _otherwise
               -> do mbCore <- frontend hsc_env mod_summary mbModIndex
                     case mbCore of
                       Nothing
                           -> return Nothing
                       Just core
                           -> do prepCore <- backend hsc_env mod_summary
                                                     mbCheckedIface core
                                 result <- codegen hsc_env mod_summary prepCore
                                 return (Just result)

-- Compile Haskell, boot and extCore in OneShot mode.
hscCompileOneShot :: Compiler HscStatus
hscCompileOneShot hsc_env mod_summary =
    compiler hsc_env mod_summary
    where mkComp = hscMkCompiler (norecompOneShot NewHscNoRecomp)
          compiler
              = case ms_hsc_src mod_summary of
                ExtCoreFile
                    -> mkComp hscCoreFrontEnd hscNewBackEnd hscCodeGenOneShot
--        1         2         3         4         5         6         7         8          9
                HsSrcFile
                    -> mkComp hscFileFrontEnd hscNewBackEnd hscCodeGenOneShot
                HsBootFile
                    -> mkComp hscFileFrontEnd hscNewBootBackEnd
                              (hscCodeGenConst (NewHscRecomp False))

-- Compile Haskell, boot and extCore in --make mode.
hscCompileMake :: Compiler (HscStatus, ModIface, ModDetails)
hscCompileMake hsc_env mod_summary
    = compiler hsc_env mod_summary
    where mkComp = hscMkCompiler norecompMake
268
269
270
          backend = case hscTarget (hsc_dflags hsc_env) of
                      HscNothing -> hscCodeGenSimple (\(i, d, g) -> (NewHscRecomp False, i, d))
                      _other     -> hscCodeGenMake
271
272
273
          compiler
              = case ms_hsc_src mod_summary of
                ExtCoreFile
274
                    -> mkComp hscCoreFrontEnd hscNewBackEnd backend
275
                HsSrcFile
276
                    -> mkComp hscFileFrontEnd hscNewBackEnd backend
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
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
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
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
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
                HsBootFile
                    -> mkComp hscFileFrontEnd hscNewBootBackEnd hscCodeGenIdentity


-- Compile Haskell, extCore to bytecode.
hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
hscCompileInteractive hsc_env mod_summary =
    hscMkCompiler norecompInteractive frontend hscNewBackEnd hscCodeGenInteractive
                  hsc_env mod_summary
    where frontend = case ms_hsc_src mod_summary of
                       ExtCoreFile -> hscCoreFrontEnd
                       HsSrcFile   -> hscFileFrontEnd
                       HsBootFile  -> panic bootErrorMsg
          bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
                         "Use 'hscCompileMake' instead."

norecompOneShot :: a -> NoRecomp a
norecompOneShot a hsc_env mod_summary 
                have_object old_iface
                mb_mod_index
    = do compilationProgressMsg (hsc_dflags hsc_env) $
           "compilation IS NOT required"
         dumpIfaceStats hsc_env
         return a

norecompMake :: NoRecomp (HscStatus, ModIface, ModDetails)
norecompMake = norecompWorker NewHscNoRecomp

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

norecompWorker :: a -> NoRecomp (a, ModIface, ModDetails)
norecompWorker a hsc_env mod_summary have_object
             old_iface mb_mod_index
    = do compilationProgressMsg (hsc_dflags hsc_env) $
           (showModuleIndex mb_mod_index ++ 
            "Skipping  " ++ showModMsg have_object mod_summary)
         new_details <- {-# SCC "tcRnIface" #-}
                        initIfaceCheck hsc_env $
                        typecheckIface old_iface
         dumpIfaceStats hsc_env
         return (a, old_iface, new_details)

hscNewBootBackEnd :: BackEnd ModGuts (HscStatus, ModIface, ModDetails)
hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result
  = do details <- mkBootModDetails hsc_env ds_result
       (new_iface, no_change) 
           <- {-# SCC "MkFinalIface" #-}
              mkIface hsc_env maybe_old_iface ds_result details
       writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
       -- And the answer is ...
       dumpIfaceStats hsc_env
       return (NewHscRecomp False, new_iface, details)

hscNewBackEnd :: BackEnd ModGuts (ModIface, ModDetails, CgGuts)
hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result
  = do 	{ 	-- OMITTED: 
		-- ; seqList imported_modules (return ())

	  let dflags    = hsc_dflags hsc_env

 	    -------------------
 	    -- FLATTENING
 	    -------------------
	; flat_result <- {-# SCC "Flattening" #-}
 			 flatten hsc_env ds_result


{-	TEMP: need to review space-leak fixing here
	NB: even the code generator can force one of the
	    thunks for constructor arguments, for newtypes in particular

	; let 	-- Rule-base accumulated from imported packages
	     pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)

		-- In one-shot mode, ZAP the external package state at
		-- this point, because we aren't going to need it from
		-- now on.  We keep the name cache, however, because
		-- tidyCore needs it.
	     pcs_middle 
		 | one_shot  = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
		 | otherwise = pcs_tc

	; pkg_rule_base `seq` pcs_middle `seq` return ()
-}

	-- alive at this point:  
	--	pcs_middle
	--	flat_result
	--      pkg_rule_base

 	    -------------------
 	    -- SIMPLIFY
 	    -------------------
	; simpl_result <- {-# SCC "Core2Core" #-}
			  core2core hsc_env flat_result

 	    -------------------
 	    -- TIDY
 	    -------------------
	; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
			         tidyProgram hsc_env simpl_result

	-- Alive at this point:  
	--	tidy_result, pcs_final
	--      hsc_env

 	    -------------------
	    -- 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
	; (new_iface, no_change)
		<- {-# SCC "MkFinalIface" #-}
		   mkIface hsc_env maybe_old_iface simpl_result details

	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change

	-- Emit external core
	; emitExternalCore dflags cg_guts

 	    -------------------
 	    -- Return the prepared code.
	; return (new_iface, details, cg_guts)
      	 }

-- Don't output any code.
hscCodeGenNothing :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
hscCodeGenNothing hsc_env mod_summary (iface, details, cgguts)
    = return (NewHscRecomp False, iface, details)

-- Generate code and return both the new ModIface and the ModDetails.
hscCodeGenMake :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails)
hscCodeGenMake hsc_env mod_summary (iface, details, cgguts)
    = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
         return (NewHscRecomp hasStub, iface, details)

-- Here we don't need the ModIface and ModDetails anymore.
hscCodeGenOneShot :: CodeGen (ModIface, ModDetails, CgGuts) HscStatus
hscCodeGenOneShot hsc_env mod_summary (_, _, cgguts)
    = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts
         return (NewHscRecomp hasStub)

hscCodeGenCompile :: CodeGen CgGuts Bool
hscCodeGenCompile hsc_env mod_summary cgguts
    = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                     -- 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
             modName = ms_mod 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

hscCodeGenIdentity :: CodeGen a a
hscCodeGenIdentity hsc_env mod_summary a = return a

hscCodeGenSimple :: (a -> b) -> CodeGen a b
hscCodeGenSimple fn hsc_env mod_summary a = return (fn a)

hscCodeGenConst :: b -> CodeGen a b
hscCodeGenConst b hsc_env mod_summary a = return b

hscCodeGenInteractive :: CodeGen (ModIface, ModDetails, CgGuts)
                                 (InteractiveStatus, ModIface, ModDetails)
hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts)
#ifdef GHCI
    = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                     -- From now on, we just use the bits we need.
                     cg_module   = this_mod,
                     cg_binds    = core_binds,
                     cg_tycons   = tycons,
                     cg_foreign  = foreign_stubs,
                     cg_home_mods = home_mods,
                     cg_dep_pkgs = dependencies } = cgguts
             dflags = hsc_dflags hsc_env
             location = ms_location mod_summary
             modName = ms_mod 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



--------------------------------------------------------------
-- Exterimental code end.
--------------------------------------------------------------

508
509
	-- no errors or warnings; the individual passes
	-- (parse/rename/typecheck) print messages themselves
510

511
hscMain
512
  :: HscEnv
513
514
515
516
  -> ModSummary
  -> Bool		-- True <=> source unchanged
  -> Bool		-- True <=> have an object file (for msgs only)
  -> Maybe ModIface	-- Old interface, if available
517
  -> Maybe (Int, Int)   -- Just (i,n) <=> module i of n (for msgs)
518
  -> IO HscResult
519

520
hscMain hsc_env mod_summary
521
	source_unchanged have_object maybe_old_iface
522
        mb_mod_index
523
 = do {
524
      (recomp_reqd, maybe_checked_iface) <- 
525
		{-# SCC "checkOldIface" #-}
526
		checkOldIface hsc_env mod_summary 
527
			      source_unchanged maybe_old_iface;
528

529
530
531
      let no_old_iface = not (isJust maybe_checked_iface)
          what_next | recomp_reqd || no_old_iface = hscRecomp 
                    | otherwise                   = hscNoRecomp
532

533
      ; what_next hsc_env mod_summary have_object 
534
		  maybe_checked_iface
535
                  mb_mod_index
536
      }
537

538

539
------------------------------
540
hscNoRecomp hsc_env mod_summary 
541
	    have_object (Just old_iface)
542
            mb_mod_index
543
 | isOneShot (ghcMode (hsc_dflags hsc_env))
544
 = do {
545
546
      compilationProgressMsg (hsc_dflags hsc_env) $
	"compilation IS NOT required";
547
548
      dumpIfaceStats hsc_env ;

549
      let { bomb = panic "hscNoRecomp:OneShot" };
550
      return (HscNoRecomp bomb bomb)
551
      }
552
 | otherwise
553
 = do	{ compilationProgressMsg (hsc_dflags hsc_env) $
554
555
		(showModuleIndex mb_mod_index ++ 
                 "Skipping  " ++ showModMsg have_object mod_summary)
556

557
	; new_details <- {-# SCC "tcRnIface" #-}
558
559
		         initIfaceCheck hsc_env $
			 typecheckIface old_iface ;
560
	; dumpIfaceStats hsc_env
561

562
563
	; return (HscNoRecomp new_details old_iface)
    }
564

565
hscNoRecomp hsc_env mod_summary 
566
567
568
569
570
	    have_object Nothing
	    mb_mod_index
  = panic "hscNoRecomp"	-- hscNoRecomp definitely expects to 
			-- have the old interface available

571
------------------------------
572
hscRecomp hsc_env mod_summary
573
	  have_object maybe_old_iface
574
          mb_mod_index
575
 = case ms_hsc_src mod_summary of
576
577
578
579
580
     HsSrcFile -> do
	front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
	case ghcMode (hsc_dflags hsc_env) of
	  JustTypecheck -> hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
	  _             -> hscBackEnd     hsc_env mod_summary maybe_old_iface front_res
581

582
     HsBootFile -> do
583
	front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
584
	hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
585

586
     ExtCoreFile -> do
587
	front_res <- hscCoreFrontEnd hsc_env mod_summary mb_mod_index
588
	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
589

590
hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do {
591
592
593
594
595
 	    -------------------
 	    -- PARSE
 	    -------------------
	; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
	; case parseCore inp 1 of
596
	    FailP s        -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
597
598
599
600
601
	    OkP rdr_module -> do {
    
 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
602
	; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
603
			      tcRnExtCore hsc_env rdr_module
604
	; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
605
606
607
608
609
610
	; case maybe_tc_result of
      	     Nothing       -> return Nothing
      	     Just mod_guts -> return (Just mod_guts)	-- No desugaring to do!
	}}
	 

611
hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
612
613
614
 	    -------------------
 	    -- DISPLAY PROGRESS MESSAGE
 	    -------------------
615
616
617
	; let dflags    = hsc_dflags hsc_env
	      one_shot  = isOneShot (ghcMode dflags)
	      toInterp  = hscTarget dflags == HscInterpreted
618
      	; when (not one_shot) $
619
		 compilationProgressMsg dflags $
620
621
		 (showModuleIndex mb_mod_index ++
                  "Compiling " ++ showModMsg (not toInterp) mod_summary)
sof's avatar
sof committed
622
			
623
624
625
626
627
 	    -------------------
 	    -- PARSE
 	    -------------------
	; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
	      hspp_buf  = ms_hspp_buf  mod_summary
628

629
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
630

631
	; case maybe_parsed of {
632
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
633
634
			    ; return Nothing } ;
      	     Right rdr_module -> do {
635

636
637
638
639
 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
640
		<- {-# SCC "Typecheck-Rename" #-}
641
		   tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
642

643
	; printErrorsAndWarnings dflags tc_msgs
644
645
646
647
648
649
650
	; case maybe_tc_result of {
      	     Nothing -> return Nothing ;
      	     Just tc_result -> do {

 	    -------------------
 	    -- DESUGAR
 	    -------------------
651
	; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
652
		 	     deSugar hsc_env tc_result
653
	; printBagOfWarnings dflags warns
654
	; return maybe_ds_result
655
656
	}}}}}

657
658
------------------------------

659
660
hscFileCheck :: HscEnv -> ModSummary -> IO HscResult
hscFileCheck hsc_env mod_summary = do {
661
662
663
 	    -------------------
 	    -- PARSE
 	    -------------------
664
665
	; let dflags    = hsc_dflags hsc_env
	      hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
666
667
	      hspp_buf  = ms_hspp_buf  mod_summary

668
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
669
670

	; case maybe_parsed of {
671
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
672
673
674
675
676
677
678
679
			    ; return HscFail } ;
      	     Right rdr_module -> do {

 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
		<- _scc_ "Typecheck-Rename" 
680
681
682
		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
			True{-save renamed syntax-}
			rdr_module
683

684
	; printErrorsAndWarnings dflags tc_msgs
685
	; case maybe_tc_result of {
686
      	     Nothing -> return (HscChecked rdr_module Nothing Nothing);
687
688
689
690
691
692
      	     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"] }
693
				   -- Rules are CoreRules, not the
694
				   -- RuleDecls we get out of the typechecker
695
696
697
698
                    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)
699
		return (HscChecked rdr_module 
700
                                   rnInfo
701
702
703
				   (Just (tcg_binds tc_result,
					  tcg_rdr_env tc_result,
					  md)))
704
	}}}}
705

706
707
708
709
------------------------------
hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
-- For hs-boot files, there's no code generation to do

710
hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing 
711
  = return HscFail
712
hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
713
  = do	{ details <- mkBootModDetails hsc_env ds_result
714
715
716

	; (new_iface, no_change) 
		<- {-# SCC "MkFinalIface" #-}
717
		   mkIface hsc_env maybe_old_iface ds_result details
718
719

	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
720
721
722
723

      	  -- And the answer is ...
	; dumpIfaceStats hsc_env

724
	; return (HscRecomp details new_iface
725
726
727
728
729
730
                            False False Nothing)
 	}

------------------------------
hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult

731
hscBackEnd hsc_env mod_summary maybe_old_iface Nothing 
732
733
  = return HscFail

734
hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) 
735
736
737
  = do 	{ 	-- OMITTED: 
		-- ; seqList imported_modules (return ())

738
	  let one_shot  = isOneShot (ghcMode dflags)
739
	      dflags    = hsc_dflags hsc_env
740

chak's avatar
chak committed
741
742
743
 	    -------------------
 	    -- FLATTENING
 	    -------------------
744
	; flat_result <- {-# SCC "Flattening" #-}
745
746
 			 flatten hsc_env ds_result

747

748
749
750
{-	TEMP: need to review space-leak fixing here
	NB: even the code generator can force one of the
	    thunks for constructor arguments, for newtypes in particular
751
752

	; let 	-- Rule-base accumulated from imported packages
753
	     pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
754
755
756
757
758
759
760
761
762
763

		-- In one-shot mode, ZAP the external package state at
		-- this point, because we aren't going to need it from
		-- now on.  We keep the name cache, however, because
		-- tidyCore needs it.
	     pcs_middle 
		 | one_shot  = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
		 | otherwise = pcs_tc

	; pkg_rule_base `seq` pcs_middle `seq` return ()
764
-}
765

766
767
	-- alive at this point:  
	--	pcs_middle
768
	--	flat_result
769
	--      pkg_rule_base
770

771
 	    -------------------
772
773
 	    -- SIMPLIFY
 	    -------------------
774
	; simpl_result <- {-# SCC "Core2Core" #-}
775
			  core2core hsc_env flat_result
776
777
778

 	    -------------------
 	    -- TIDY
779
 	    -------------------
780
	; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
781
			         tidyProgram hsc_env simpl_result
782

783
784
	-- Alive at this point:  
	--	tidy_result, pcs_final
785
	--      hsc_env
786

787
788
789
790
791
792
 	    -------------------
	    -- 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
793
794
795
	; (new_iface, no_change)
		<- {-# SCC "MkFinalIface" #-}
		   mkIface hsc_env maybe_old_iface simpl_result details
796
797

	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
798
799
800
801

	    -- Space leak reduction: throw away the new interface if
	    -- we're in one-shot mode; we won't be needing it any
	    -- more.
802
	; final_iface <- if one_shot then return (error "no final iface")
803
804
805
806
			 else return new_iface

	    -- Build the final ModDetails (except in one-shot mode, where
	    -- we won't need this information after compilation).
807
808
809
810
811
	; final_details <- if one_shot then return (error "no final details")
		 	   else return $! details

	-- Emit external core
	; emitExternalCore dflags cg_guts
812
813
814
815

 	    -------------------
 	    -- CONVERT TO STG and COMPLETE CODE GENERATION
	; (stub_h_exists, stub_c_exists, maybe_bcos)
816
		<- hscCodeGen dflags (ms_location mod_summary) cg_guts
817

818
819
820
821
      	  -- And the answer is ...
	; dumpIfaceStats hsc_env

	; return (HscRecomp final_details
822
			    final_iface
823
                            stub_h_exists stub_c_exists
824
      			    maybe_bcos)
825
      	 }
826
827


828

829
hscCodeGen dflags location
830
    CgGuts{  -- This is the last use of the ModGuts in a compilation.
831
	      -- From now on, we just use the bits we need.
832
833
834
835
836
        cg_module   = this_mod,
	cg_binds    = core_binds,
	cg_tycons   = tycons,
	cg_dir_imps = dir_imps,
	cg_foreign  = foreign_stubs,
837
	cg_home_mods = home_mods,
838
839
840
841
842
	cg_dep_pkgs = dependencies     }  = do {

  let { data_tycons = filter isDataTyCon tycons } ;
	-- cg_tycons includes newtypes, for the benefit of External Core,
	-- but we don't generate any code for newtypes
843
844
845
846

 	    -------------------
 	    -- PREPARE FOR CODE GENERATION
	    -- Do saturation and convert to A-normal form
847
  prepd_binds <- {-# SCC "CorePrep" #-}
848
		 corePrepPgm dflags core_binds data_tycons ;
849

850
  case hscTarget dflags of
851
852
853
854
855
      HscNothing -> return (False, False, Nothing)

      HscInterpreted ->
#ifdef GHCI
	do  -----------------  Generate byte code ------------------
856
	    comp_bc <- byteCodeGen dflags prepd_binds data_tycons
857
858
859
	
	    ------------------ Create f-x-dynamic C-side stuff ---
	    (istub_h_exists, istub_c_exists) 
860
	       <- outputForeignStubs dflags this_mod location foreign_stubs
861
	    
862
	    return ( istub_h_exists, istub_c_exists, Just comp_bc )
863
864
865
866
867
868
869
#else
	panic "GHC not compiled with interpreter"
#endif

      other ->
	do
	    -----------------  Convert to STG ------------------
870
	    (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-}
871
	    		 myCoreToStg dflags home_mods this_mod prepd_binds	
872
873

            ------------------  Code generation ------------------
874
	    abstractC <- {-# SCC "CodeGen" #-}
875
876
877
		         codeGen dflags home_mods this_mod data_tycons
				 foreign_stubs dir_imps cost_centre_info
				 stg_binds
878

879
880
	    ------------------  Code output -----------------------
	    (stub_h_exists, stub_c_exists)
881
		     <- codeOutput dflags this_mod location foreign_stubs 
882
883
				dependencies abstractC

884
	    return (stub_h_exists, stub_c_exists, Nothing)
885
   }
sof's avatar
sof committed
886

887

888
889
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
890
  maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
891
892
893
  case maybe_cmm of
    Nothing -> return False
    Just cmm -> do
894
	codeOutput dflags no_mod no_loc NoStubs [] [cmm]
895
896
897
	return True
  where
	no_mod = panic "hscCmmFile: no_mod"
898
899
900
	no_loc = ModLocation{ ml_hs_file  = Just filename,
                              ml_hi_file  = panic "hscCmmFile: no hi file",
                              ml_obj_file = panic "hscCmmFile: no obj file" }
901
902


903
myParseModule dflags src_filename maybe_src_buf
904
905
906
 =    --------------------------  Parser  ----------------
      showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
907
908
909
910
911
912
913

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

915
      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
916

917
      case unP parseModule (mkPState buf loc dflags) of {
918

919
	PFailed span err -> return (Left (mkPlainErrMsg span err));
920

921
	POk _ rdr_module -> do {
922

923
924
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
925
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
926
927
			   (ppSourceStats False rdr_module) ;
      
928
      return (Right rdr_module)
929
	-- ToDo: free the string buffer later.
930
      }}
931
932


933
myCoreToStg dflags home_mods this_mod prepd_binds
934
 = do 
935
      stg_binds <- {-# SCC "Core2Stg" #-}
936
	     coreToStg home_mods prepd_binds
937

938
      (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
939
	     stg2stg dflags home_mods this_mod stg_binds
940

941
      return (stg_binds2, cost_centre_info)
942
943
\end{code}

944

945
946
%************************************************************************
%*									*
947
\subsection{Compiling a do-statement}
948
949
950
%*									*
%************************************************************************

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
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]
973

974
975
976
977
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
978
979
980
981
#ifdef GHCI
hscStmt		-- Compile a stmt all the way to an HValue, but don't run it
  :: HscEnv
  -> String			-- The statement
982
  -> IO (Maybe (HscEnv, [Name], HValue))
chak's avatar
chak committed
983

984
hscStmt hsc_env stmt
985
986
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
	; case maybe_stmt of {
987
988
989
      	     Nothing	  -> return Nothing ;	-- Parse error
      	     Just Nothing -> return Nothing ;	-- Empty line
      	     Just (Just parsed_stmt) -> do {	-- The real stuff
990

991
		-- Rename and typecheck it
992
993
	  let icontext = hsc_IC hsc_env
	; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
994

995
	; case maybe_tc_result of {
996
		Nothing -> return Nothing ;
997
		Just (new_ic, bound_names, tc_expr) -> do {
998

999
		-- Then desugar, code gen, and link it
1000
	; hval <- compileExpr hsc_env iNTERACTIVE 
1001
1002
1003
			      (ic_rn_gbl_env new_ic) 
			      (ic_type_env new_ic)
			      tc_expr
1004

1005
	; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
1006
	}}}}}
1007

1008
1009
1010
hscTcExpr	-- Typecheck an expression (but don't run it)
  :: HscEnv
  -> String			-- The expression
1011
  -> IO (Maybe Type)
1012

1013
hscTcExpr hsc_env expr
1014
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
1015
	; let icontext = hsc_IC hsc_env
1016
	; case maybe_stmt of {
1017
	     Nothing      -> return Nothing ;	-- Parse error
1018
	     Just (Just (L _ (ExprStmt expr _ _)))
1019
			-> tcRnExpr hsc_env icontext expr ;
1020
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
1021
			        return Nothing } ;
1022
1023
1024
1025
1026
1027
1028
      	     } }

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

1029
hscKcType hsc_env str
1030
  = do	{ maybe_type <- hscParseType (hsc_dflags hsc_env) str
1031
	; let icontext = hsc_IC hsc_env
1032
1033
	; case maybe_type of {
	     Just ty	-> tcRnType hsc_env icontext ty ;
1034
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
1035
			        return Nothing } ;
1036
      	     Nothing    -> return Nothing } }
1037
#endif
1038
\end{code}
1039

1040
\begin{code}
1041
#ifdef GHCI
1042
1043
1044
1045
1046
hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
hscParseStmt = hscParseThing parseStmt

hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
hscParseType = hscParseThing parseType
1047
#endif
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058

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
1059
1060
 = showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
1061

1062
      buf <- stringToStringBuffer str
1063

1064
      let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
1065

1066
      case unP parser (mkPState buf loc dflags) of {
1067

1068
1069
	PFailed span err -> do { printError span err;
                                 return Nothing };
1070

1071
	POk _ thing -> do {
1072

1073
1074
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
1075
1076
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
      return (Just thing)
1077
1078
      }}
\end{code}
1079

1080
1081
%************************************************************************
%*									*
1082
	Desugar, simplify, convert to bytecode, and link an expression
1083
1084
1085
1086
1087
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
1088
compileExpr :: HscEnv 
1089
	    -> Module -> GlobalRdrEnv -> TypeEnv
1090
	    -> LHsExpr Id
1091
	    -> IO HValue
1092

1093
compileExpr hsc_env this_mod rdr_env type_env tc_expr
1094
1095
1096
  = do	{ let { dflags  = hsc_dflags hsc_env ;
		lint_on = dopt Opt_DoCoreLinting dflags }
	      
1097
	 	-- Desugar it
1098
	; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
1099
1100
	
		-- Flatten it
1101
	; flat_expr <- flattenExpr hsc_env ds_expr
1102

1103
1104
		-- Simplify it
	; simpl_expr <- simplifyExpr dflags flat_expr
1105

1106
		-- Tidy it (temporary, until coreSat does cloning)
1107
	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1108

1109
1110
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
1111

1112
1113
1114
1115
1116
1117
1118
1119
1120
		-- 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 ()

1121
1122
		-- Convert to BCOs
	; bcos <- coreExprToBCOs dflags prepd_expr
1123

1124
		-- link it
1125
	; hval <- linkExpr hsc_env bcos
1126

1127
1128
	; return hval
     }
1129
1130
1131
#endif
\end{code}

1132

1133
1134
%************************************************************************
%*									*
1135
	Statistics on reading interfaces
1136
1137
1138
1139
%*									*
%************************************************************************

\begin{code}
1140
1141
1142
1143
1144
1145
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
  = do	{ eps <- readIORef (hsc_EPS hsc_env)
	; dumpIfSet (dump_if_trace || dump_rn_stats)
	      	    "Interface statistics"
	      	    (ifaceStats eps) }
1146
  where
1147
1148
1149
    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
1150
\end{code}
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166

%************************************************************************
%*									*
	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}