HscMain.lhs 19.2 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
module HscMain ( HscResult(..), hscMain, 
#ifdef GHCI
10
		 hscStmt,
11
#endif
12
		 initPersistentCompilerState ) where
13

14
#include "HsVersions.h"
15

16
#ifdef GHCI
17
import ByteCodeGen	( byteCodeGen )
18
19
20
21
22
import CoreTidy		( tidyCoreExpr )
import CorePrep		( corePrepExpr )
import Rename		( renameStmt )
import RdrHsSyn		( RdrNameStmt )
import Type		( Type )
23
import Id		( Id, idName, setGlobalIdDetails )
24
import IdInfo		( GlobalIdDetails(VanillaGlobal) )
25
import HscTypes		( InteractiveContext(..), TyThing(..) )
26
import PrelNames	( iNTERACTIVE )
27
import StringBuffer	( stringToStringBuffer )
28
29
#endif

30
31
import HsSyn

32
33
34
import Id		( idName )
import IdInfo		( CafInfo(..), CgInfoEnv, CgInfo(..) )
import StringBuffer	( hGetStringBuffer, freeStringBuffer )
35
import Parser
36
import Lex		( PState(..), ParseResult(..) )
37
import SrcLoc		( mkSrcLoc )
38
import Rename		( checkOldIface, renameModule, closeIfaceDecls )
39
import Rules		( emptyRuleBase )
40
import PrelInfo		( wiredInThingEnv, wiredInThings )
41
import PrelNames	( vanillaSyntaxMap, knownKeyNames )
42
import MkIface		( mkFinalIface )
43
import TcModule
44
import InstEnv		( emptyInstEnv )
45
46
import Desugar
import SimplCore
47
import CoreUtils	( coreBindsSize )
48
import CoreTidy		( tidyCorePgm )
49
50
import CorePrep		( corePrepPgm )
import StgSyn
51
import CoreToStg	( coreToStg )
52
53
import SimplStg		( stg2stg )
import CodeGen		( codeGen )
54
import CodeOutput	( codeOutput )
55

56
57
import Module		( ModuleName, moduleName, mkHomeModule, 
			  moduleUserString )
58
import CmdLineOpts
59
import ErrUtils		( dumpIfSet_dyn, showPass, printError )
60
import Util		( unJust )
61
import UniqSupply	( mkSplitUniqSupply )
62

63
import Bag		( emptyBag )
64
import Outputable
65
import Interpreter
66
import CmStaticInfo	( GhciMode(..) )
67
import HscStats		( ppSourceStats )
68
import HscTypes
69
import FiniteMap	( FiniteMap, plusFM, emptyFM, addToFM )
70
import OccName		( OccName )
71
import Name		( Name, nameModule, nameOccName, getName, isGlobalName )
72
import NameEnv		( emptyNameEnv, mkNameEnv )
73
import Module		( Module, lookupModuleEnvByName )
74
75
76
import Maybes		( orElse )

import IOExts		( newIORef, readIORef, writeIORef, unsafePerformIO )
77

78
import Monad		( when )
79
import Maybe		( isJust )
80
import IO
81
82
\end{code}

83
84
85
86
87
88
89

%************************************************************************
%*									*
\subsection{The main compiler pipeline}
%*									*
%************************************************************************

90
\begin{code}
91
data HscResult
92
93
94
95
96
97
98
99
100
101
   -- compilation failed
   = HscFail     PersistentCompilerState -- updated PCS
   -- concluded that it wasn't necessary
   | HscNoRecomp PersistentCompilerState -- updated PCS
                 ModDetails  	         -- new details (HomeSymbolTable additions)
	         ModIface	         -- new iface (if any compilation was done)
   -- did recompilation
   | HscRecomp   PersistentCompilerState -- updated PCS
                 ModDetails  		 -- new details (HomeSymbolTable additions)
                 ModIface		 -- new iface (if any compilation was done)
102
103
	         Bool	 	 	-- stub_h exists
	         Bool  		 	-- stub_c exists
104
	         (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
105
106
             

107
108
	-- no errors or warnings; the individual passes
	-- (parse/rename/typecheck) print messages themselves
109

110
hscMain
111
112
  :: GhciMode
  -> DynFlags
113
  -> Module
114
  -> ModuleLocation		-- location info
115
116
  -> Bool			-- True <=> source unchanged
  -> Bool			-- True <=> have an object file (for msgs only)
117
  -> Maybe ModIface		-- old interface, if available
118
  -> HomeSymbolTable		-- for home module ModDetails
119
  -> HomeIfaceTable
120
  -> PersistentCompilerState    -- IN: persistent compiler state
121
  -> IO HscResult
122

123
124
hscMain ghci_mode dflags mod location source_unchanged have_object 
	maybe_old_iface hst hit pcs
125
 = do {
126
127
128
      showPass dflags ("Checking old interface for hs = " 
			++ show (ml_hs_file location)
                	++ ", hspp = " ++ show (ml_hspp_file location));
129

130
      (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
131
         <- checkOldIface ghci_mode dflags hit hst pcs 
132
		(unJust "hscMain" (ml_hi_file location))
133
		source_unchanged maybe_old_iface;
134
135

      if errs_found then
136
         return (HscFail pcs_ch)
137
      else do {
138

139
140
141
      let no_old_iface = not (isJust maybe_checked_iface)
          what_next | recomp_reqd || no_old_iface = hscRecomp 
                    | otherwise                   = hscNoRecomp
142
      ;
143
144
      what_next ghci_mode dflags have_object mod location 
		maybe_checked_iface hst hit pcs_ch
145
      }}
146
147


148
-- we definitely expect to have the old interface available
149
150
hscNoRecomp ghci_mode dflags have_object 
	    mod location (Just old_iface) hst hit pcs_ch
151
 | ghci_mode == OneShot
152
153
 = do {
      hPutStrLn stderr "compilation IS NOT required";
154
      let { bomb = panic "hscNoRecomp:OneShot" };
155
156
      return (HscNoRecomp pcs_ch bomb bomb)
      }
157
 | otherwise
158
 = do {
159
      when (verbosity dflags >= 1) $
160
161
		hPutStrLn stderr ("Skipping  " ++ 
			compMsg have_object mod location);
162

163
164
      -- CLOSURE
      (pcs_cl, closure_errs, cl_hs_decls) 
165
         <- closeIfaceDecls dflags hit hst pcs_ch old_iface ;
166
      if closure_errs then 
167
         return (HscFail pcs_cl) 
168
169
170
      else do {

      -- TYPECHECK
171
172
173
      maybe_tc_result 
	<- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls);

174
      case maybe_tc_result of {
175
         Nothing -> return (HscFail pcs_cl);
176
         Just (pcs_tc, new_details) ->
177

178
      return (HscNoRecomp pcs_tc new_details old_iface)
179
      }}}
180

181
compMsg use_object mod location =
182
    mod_str ++ take (max 0 (16 - length mod_str)) (repeat ' ')
183
184
185
186
187
    ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
    ++ (if use_object
	  then unJust "hscRecomp" (ml_obj_file location)
	  else "interpreted")
    ++ " )"
188
189
 where mod_str = moduleUserString mod

190

191
192
hscRecomp ghci_mode dflags have_object 
	  mod location maybe_checked_iface hst hit pcs_ch
193
194
195
196
 = do	{
      	  -- what target are we shooting for?
      	; let toInterp = dopt_HscLang dflags == HscInterpreted

197
198
199
200
      	; when (verbosity dflags >= 1) $
		hPutStrLn stderr ("Compiling " ++ 
			compMsg (not toInterp) mod location);

201
202
203
 	    -------------------
 	    -- PARSE
 	    -------------------
204
205
	; maybe_parsed <- myParseModule dflags 
                             (unJust "hscRecomp:hspp" (ml_hspp_file location))
206
207
208
	; case maybe_parsed of {
      	     Nothing -> return (HscFail pcs_ch);
      	     Just rdr_module -> do {
209
	; let this_mod = mkHomeModule (hsModuleName rdr_module)
210
211
212
213
    
 	    -------------------
 	    -- RENAME
 	    -------------------
214
	; (pcs_rn, print_unqualified, maybe_rn_result) 
215
216
      	     <- _scc_ "Rename" 
		 renameModule dflags hit hst pcs_ch this_mod rdr_module
217
      	; case maybe_rn_result of {
218
      	     Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
219
      	     Just (is_exported, new_iface, rn_hs_decls) -> do {
220
    
221
222
223
224
225
226
227
228
229
 	    -- In interactive mode, we don't want to discard any top-level entities at
	    -- all (eg. do not inline them away during simplification), and retain them
	    -- all in the TypeEnv so they are available from the command line.
	    --
	    -- isGlobalName separates the user-defined top-level names from those
	    -- introduced by the type checker.
	; let dont_discard | ghci_mode == Interactive = isGlobalName
			   | otherwise = is_exported

230
231
232
 	    -------------------
 	    -- TYPECHECK
 	    -------------------
233
234
	; maybe_tc_result 
	    <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface 
235
					     print_unqualified rn_hs_decls 
236
	; case maybe_tc_result of {
237
      	     Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
238
      	     Just (pcs_tc, tc_result) -> do {
239
240
    
 	    -------------------
241
242
 	    -- DESUGAR
 	    -------------------
243
	; (ds_details, foreign_stuff) 
244
245
             <- _scc_ "DeSugar" 
		deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
246
247

 	    -------------------
248
249
 	    -- SIMPLIFY
 	    -------------------
250
	; simpl_details
251
	     <- _scc_     "Core2Core"
252
		core2core dflags pcs_tc hst dont_discard ds_details
253
254
255

 	    -------------------
 	    -- TIDY
256
 	    -------------------
257
258
259
260
261
262
263
264
265
266
267
268
269
	; cg_info_ref <- newIORef Nothing ;
	; let cg_info :: CgInfoEnv
	      cg_info = unsafePerformIO $ do {
			   maybe_cg_env <- readIORef cg_info_ref ;
			   case maybe_cg_env of
			     Just env -> return env
			     Nothing  -> do { printError "Urk! Looked at CgInfo too early!";
					      return emptyNameEnv } }
		-- cg_info_ref will be filled in just after restOfCodeGeneration
		-- Meanwhile, tidyCorePgm is careful not to look at cg_info!

	; (pcs_simpl, tidy_details) 
	     <- tidyCorePgm dflags this_mod pcs_tc cg_info simpl_details
270
      
271
 	    -------------------
272
 	    -- PREPARE FOR CODE GENERATION
273
 	    -------------------
274
275
	      -- Do saturation and convert to A-normal form
	; prepd_details <- corePrepPgm dflags tidy_details
276

277
 	    -------------------
278
 	    -- CONVERT TO STG and COMPLETE CODE GENERATION
279
 	    -------------------
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
	; let
	    ModDetails{md_binds=binds, md_types=env_tc} = prepd_details

	    local_tycons     = typeEnvTyCons  env_tc
	    local_classes    = typeEnvClasses env_tc

 	    imported_module_names = map ideclName (hsModuleImports rdr_module)
	    imported_modules = map mod_name_to_Module imported_module_names

	    (h_code,c_code,fe_binders) = foreign_stuff
	
	    pit = pcs_PIT pcs_simpl

	    mod_name_to_Module :: ModuleName -> Module
	    mod_name_to_Module nm
	       = let str_mi = lookupModuleEnvByName hit nm `orElse`
			      lookupModuleEnvByName pit nm `orElse`
			      pprPanic "mod_name_to_Module: no hst or pst mapping for" 
			       	(ppr nm)
		 in  mi_module str_mi

301
	; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
302
303
304
305
306
307
308
309
310
311
312
313
314
315
	   <- if toInterp
	        then do 
		    -----------------  Generate byte code ------------------
		    (bcos,itbl_env) <- byteCodeGen dflags binds 
					local_tycons local_classes

		    -- Fill in the code-gen info
		    writeIORef cg_info_ref (Just emptyNameEnv)

		    ------------------ BUILD THE NEW ModIface ------------
		    final_iface <- _scc_ "MkFinalIface" 
			  mkFinalIface ghci_mode dflags location 
                                   maybe_checked_iface new_iface tidy_details

316
      		    return ( False, False, Just (bcos,itbl_env), final_iface )
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

	        else do
		    -----------------  Convert to STG ------------------
		    (stg_binds, cost_centre_info, stg_back_end_info) 
		    	      <- _scc_ "CoreToStg"
		    		  myCoreToStg dflags this_mod binds
		    
		    -- Fill in the code-gen info for the earlier tidyCorePgm
		    writeIORef cg_info_ref (Just stg_back_end_info)

		    ------------------ BUILD THE NEW ModIface ------------
		    final_iface <- _scc_ "MkFinalIface" 
			  mkFinalIface ghci_mode dflags location 
                                   maybe_checked_iface new_iface tidy_details

		    ------------------  Code generation ------------------
		    abstractC <- _scc_ "CodeGen"
		    		  codeGen dflags this_mod imported_modules
		    			 cost_centre_info fe_binders
		    			 local_tycons stg_binds
		    
		    ------------------  Code output -----------------------
339
		    (stub_h_exists, stub_c_exists)
340
341
342
343
		       <- codeOutput dflags this_mod local_tycons
		    	     binds stg_binds
		    	     c_code h_code abstractC
	      		
344
	      	    return (stub_h_exists, stub_c_exists, Nothing, final_iface)
345
346

	; let final_details = tidy_details {md_binds = []} 
347

348
349

      	  -- and the answer is ...
350
351
352
	; return (HscRecomp pcs_simpl
			    final_details
			    final_iface
353
                            stub_h_exists stub_c_exists
354
      			    maybe_bcos)
355
      	  }}}}}}}
356

357
myParseModule dflags src_filename
358
 = do --------------------------  Parser  ----------------
359
      showPass dflags "Parser"
360
      _scc_  "Parser" do
361
362

      buf <- hGetStringBuffer True{-expand tabs-} src_filename
363

364
      let glaexts | dopt Opt_GlasgowExts dflags = 1#
365
	          | otherwise 		        = 0#
366

367
368
369
      case parseModule buf PState{ bol = 0#, atbol = 1#,
	 		           context = [], glasgow_exts = glaexts,
  			           loc = mkSrcLoc (_PK_ src_filename) 1 } of {
370

371
	PFailed err -> do { hPutStrLn stderr (showSDoc err);
372
                            freeStringBuffer buf;
373
                            return Nothing };
374

375
	POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
376

377
378
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
379
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
380
381
			   (ppSourceStats False rdr_module) ;
      
382
      return (Just rdr_module)
383
	-- ToDo: free the string buffer later.
384
      }}
385
386


387
myCoreToStg dflags this_mod tidy_binds
388
 = do 
389
      () <- coreBindsSize tidy_binds `seq` return ()
390
391
392
393
      -- TEMP: the above call zaps some space usage allocated by the
      -- simplifier, which for reasons I don't understand, persists
      -- thoroughout code generation

394
      stg_binds <- _scc_ "Core2Stg" coreToStg dflags tidy_binds
395

396
397
      (stg_binds2, cost_centre_info)
	   <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
398

399
400
401
402
403
404
405
406
407
      let env_rhs :: CgInfoEnv
	  env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info)
			      | (bind,_) <- stg_binds2, 
			        let caf_info 
				     | stgBindHasCafRefs bind = MayHaveCafRefs
				     | otherwise = NoCafRefs,
			        (bndr,rhs) <- stgBindPairs bind ]

      return (stg_binds2, cost_centre_info, env_rhs)
408
   where
409
410
      stgBindPairs (StgNonRec _ b r) = [(b,r)]
      stgBindPairs (StgRec    _ prs) = prs
411
412
\end{code}

413

414
415
%************************************************************************
%*									*
416
\subsection{Compiling a do-statement}
417
418
419
%*									*
%************************************************************************

420
\begin{code}
421
#ifdef GHCI
422
hscStmt
423
424
425
426
  :: DynFlags
  -> HomeSymbolTable	
  -> HomeIfaceTable
  -> PersistentCompilerState    -- IN: persistent compiler state
427
428
  -> InteractiveContext		-- Context for compiling
  -> String			-- The statement
429
  -> Bool			-- just treat it as an expression
430
  -> IO ( PersistentCompilerState, 
431
	  Maybe ( [Id], 
432
433
		  Type, 
		  UnlinkedBCOExpr) )
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
\end{code}

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]
458

459
460
461
462
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
463
hscStmt dflags hst hit pcs0 icontext stmt just_expr
464
465
   = let 
	InteractiveContext { 
466
	     ic_rn_env   = rn_env, 
467
	     ic_type_env = type_env,
468
	     ic_module   = scope_mod } = icontext
469
470
471
     in
     do { maybe_stmt <- hscParseStmt dflags stmt
	; case maybe_stmt of
472
      	     Nothing -> return (pcs0, Nothing)
473
      	     Just parsed_stmt -> do {
474

475
476
477
478
479
480
481
482
483
	   let { notExprStmt (ExprStmt _ _) = False;
	         notExprStmt _              = True 
	       };

	   if (just_expr && notExprStmt parsed_stmt)
		then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'")
		        return (pcs0, Nothing)
		else do {

484
		-- Rename it
485
	  (pcs1, print_unqual, maybe_renamed_stmt)
486
487
488
		 <- renameStmt dflags hit hst pcs0 scope_mod 
				iNTERACTIVE rn_env parsed_stmt

489
490
491
	; case maybe_renamed_stmt of
		Nothing -> return (pcs0, Nothing)
		Just (bound_names, rn_stmt) -> do {
492

493
		-- Typecheck it
494
495
496
497
498
499
500
501
502
503
504
	  maybe_tc_return <- 
	    if just_expr 
		then case rn_stmt of { (syn, ExprStmt e _, decls) -> 
		     typecheckExpr dflags pcs1 hst type_env
			   print_unqual iNTERACTIVE (syn,e,decls) }
		else typecheckStmt dflags pcs1 hst type_env
			   print_unqual iNTERACTIVE bound_names rn_stmt

	; case maybe_tc_return of
		Nothing -> return (pcs0, Nothing)
		Just (pcs2, tc_expr, bound_ids, ty) ->  do {
505

506
		-- Desugar it
507
	  ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
508
509
	
		-- Simplify it
510
	; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr
511

512
513
514
		-- Tidy it (temporary, until coreSat does cloning)
	; tidy_expr <- tidyCoreExpr simpl_expr

515
516
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
517

518
		-- Convert to BCOs
519
	; bcos <- coreExprToBCOs dflags prepd_expr
520
521

	; let
522
		-- Make all the bound ids "global" ids, now that
523
524
525
526
		-- they're notionally top-level bindings.  This is
		-- important: otherwise when we come to compile an expression
		-- using these ids later, the byte code generator will consider
		-- the occurrences to be free rather than global.
527
	     global_bound_ids = map globaliseId bound_ids;
528
	     globaliseId id   = setGlobalIdDetails id VanillaGlobal
529

530
	; return (pcs2, Just (global_bound_ids, ty, bcos))
531

532
533
534
535
     }}}}}

hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
hscParseStmt dflags str
536
537
 = do --------------------------  Parser  ----------------
      showPass dflags "Parser"
538
      _scc_ "Parser" do
539

540
      buf <- stringToStringBuffer str
541

542
      let glaexts | dopt Opt_GlasgowExts dflags = 1#
543
       	          | otherwise  	                = 0#
544

545
      case parseStmt buf PState{ bol = 0#, atbol = 1#,
546
547
	 		         context = [], glasgow_exts = glaexts,
			         loc = mkSrcLoc SLIT("<no file>") 0 } of {
548

549
	PFailed err -> do { hPutStrLn stderr (showSDoc err);
550
--	Not yet implemented in <4.11    freeStringBuffer buf;
551
                            return Nothing };
552

553
554
555
556
	-- no stmt: the line consisted of just space or comments
	POk _ Nothing -> return Nothing;

	POk _ (Just rdr_stmt) -> do {
557

558
559
560
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
      --freeStringBuffer buf;
561
562
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
      return (Just rdr_stmt)
563
      }}
564
#endif
565
\end{code}
566

567
568
569
570
571
572
573
%************************************************************************
%*									*
\subsection{Initial persistent state}
%*									*
%************************************************************************

\begin{code}
574
initPersistentCompilerState :: IO PersistentCompilerState
575
initPersistentCompilerState 
576
577
  = do prs <- initPersistentRenamerState
       return (
578
        PCS { pcs_PIT   = emptyIfaceTable,
579
              pcs_PTE   = wiredInThingEnv,
580
	      pcs_insts = emptyInstEnv,
581
	      pcs_rules = emptyRuleBase,
582
	      pcs_PRS   = prs
583
584
            }
        )
585

586
initPersistentRenamerState :: IO PersistentRenamerState
587
  = do us <- mkSplitUniqSupply 'r'
588
       return (
589
590
591
        PRS { prsOrig  = NameSupply { nsUniqs = us,
				      nsNames = initOrigNames,
			      	      nsIPs   = emptyFM },
592
593
594
595
	      prsDecls 	 = (emptyNameEnv, 0),
	      prsInsts 	 = (emptyBag, 0),
	      prsRules 	 = (emptyBag, 0),
	      prsImpMods = emptyFM
596
597
            }
        )
598

599
initOrigNames :: FiniteMap (ModuleName,OccName) Name
600
601
602
603
604
605
initOrigNames 
   = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
     where
        grab names = foldl add emptyFM names
        add env name 
           = addToFM env (moduleName (nameModule name), nameOccName name) name
606
607


608
initRules :: PackageRuleBase
609
610
611
initRules = emptyRuleBase
{- SHOULD BE (ish)
            foldl add emptyVarEnv builtinRules
612
	  where
613
	    add env (name,rule) 
614
615
              = extendRuleBase env name rule
-}
616
\end{code}