HscMain.lhs 24.3 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
	) where
18

19
#include "HsVersions.h"
20

21
#ifdef GHCI
22
import HsSyn		( Stmt(..), LHsExpr, LStmt, LHsType )
23
import Module		( Module )
24 25 26
import CodeOutput	( outputForeignStubs )
import ByteCodeGen	( byteCodeGen, coreExprToBCOs )
import Linker		( HValue, linkExpr )
27
import CoreTidy		( tidyExpr )
28
import CorePrep		( corePrepExpr )
29
import Flattening	( flattenExpr )
30
import TcRnDriver	( tcRnStmt, tcRnExpr, tcRnType ) 
31 32
import Type		( Type )
import PrelNames	( iNTERACTIVE )
33
import Kind		( Kind )
34
import CoreLint		( lintUnfolding )
35
import DsMeta		( templateHaskellNames )
36
import SrcLoc		( noSrcLoc )
37
import VarEnv		( emptyTidyEnv )
38 39
#endif

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

70
import DynFlags
71
import ErrUtils
72
import UniqSupply	( mkSplitUniqSupply )
73

74
import Outputable
75
import HscStats		( ppSourceStats )
76
import HscTypes
77 78 79
import MkExternalCore	( emitExternalCore )
import ParserCore
import ParserCoreUtils
80
import FastString
81
import Maybes		( expectJust )
82
import Bag		( unitBag )
83
import Monad		( when )
84
import Maybe		( isJust )
85
import IO
86
import DATA_IOREF	( newIORef, readIORef )
87 88
\end{code}

89 90 91

%************************************************************************
%*									*
92 93 94 95 96
		Initialisation
%*									*
%************************************************************************

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

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
126 127 128
%*									*
%************************************************************************

129
\begin{code}
130
data HscResult
131
   -- Compilation failed
132 133 134
   = HscFail

   -- In IDE mode: we just do the static/dynamic checks
135
   | HscChecked 
136 137 138 139 140 141
        -- parsed
	(Located (HsModule RdrName))
        -- renamed
	(Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
        -- typechecked
	(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
142 143 144

   -- Concluded that it wasn't necessary
   | HscNoRecomp ModDetails  	         -- new details (HomeSymbolTable additions)
145
	         ModIface	         -- new iface (if any compilation was done)
146 147 148 149

   -- Did recompilation
   | HscRecomp   ModDetails  		-- new details (HomeSymbolTable additions)
                 ModIface		-- new iface (if any compilation was done)
150 151
	         Bool	 	 	-- stub_h exists
	         Bool  		 	-- stub_c exists
152
	         (Maybe CompiledByteCode)
153

154 155 156 157

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

158 159
	-- no errors or warnings; the individual passes
	-- (parse/rename/typecheck) print messages themselves
160

161
hscMain
162
  :: HscEnv
163 164 165 166
  -> ModSummary
  -> Bool		-- True <=> source unchanged
  -> Bool		-- True <=> have an object file (for msgs only)
  -> Maybe ModIface	-- Old interface, if available
167
  -> Maybe (Int, Int)   -- Just (i,n) <=> module i of n (for msgs)
168
  -> IO HscResult
169

170
hscMain hsc_env mod_summary
171
	source_unchanged have_object maybe_old_iface
172
        mb_mod_index
173
 = do {
174
      (recomp_reqd, maybe_checked_iface) <- 
175
		{-# SCC "checkOldIface" #-}
176
		checkOldIface hsc_env mod_summary 
177
			      source_unchanged maybe_old_iface;
178

179 180 181
      let no_old_iface = not (isJust maybe_checked_iface)
          what_next | recomp_reqd || no_old_iface = hscRecomp 
                    | otherwise                   = hscNoRecomp
182

183
      ; what_next hsc_env mod_summary have_object 
184
		  maybe_checked_iface
185
                  mb_mod_index
186
      }
187

188

189
------------------------------
190
hscNoRecomp hsc_env mod_summary 
191
	    have_object (Just old_iface)
192
            mb_mod_index
193
 | isOneShot (ghcMode (hsc_dflags hsc_env))
194
 = do {
195 196
      compilationProgressMsg (hsc_dflags hsc_env) $
	"compilation IS NOT required";
197 198
      dumpIfaceStats hsc_env ;

199
      let { bomb = panic "hscNoRecomp:OneShot" };
200
      return (HscNoRecomp bomb bomb)
201
      }
202
 | otherwise
203
 = do	{ compilationProgressMsg (hsc_dflags hsc_env) $
204 205
		(showModuleIndex mb_mod_index ++ 
                 "Skipping  " ++ showModMsg have_object mod_summary)
206

207
	; new_details <- {-# SCC "tcRnIface" #-}
208 209
		         initIfaceCheck hsc_env $
			 typecheckIface old_iface ;
210
	; dumpIfaceStats hsc_env
211

212 213
	; return (HscNoRecomp new_details old_iface)
    }
214

215
hscNoRecomp hsc_env mod_summary 
216 217 218 219 220
	    have_object Nothing
	    mb_mod_index
  = panic "hscNoRecomp"	-- hscNoRecomp definitely expects to 
			-- have the old interface available

221
------------------------------
222
hscRecomp hsc_env mod_summary
223
	  have_object maybe_old_iface
224
          mb_mod_index
225
 = case ms_hsc_src mod_summary of
226 227 228 229 230
     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
231

232
     HsBootFile -> do
233
	front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
234
	hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
235

236
     ExtCoreFile -> do
237
	front_res <- hscCoreFrontEnd hsc_env mod_summary
238
	hscBackEnd hsc_env mod_summary maybe_old_iface front_res
239

240
hscCoreFrontEnd hsc_env mod_summary = do {
241 242 243 244 245
 	    -------------------
 	    -- PARSE
 	    -------------------
	; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
	; case parseCore inp 1 of
246
	    FailP s        -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
247 248 249 250 251
	    OkP rdr_module -> do {
    
 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
252
	; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
253
			      tcRnExtCore hsc_env rdr_module
254
	; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
255 256 257 258 259 260
	; case maybe_tc_result of
      	     Nothing       -> return Nothing
      	     Just mod_guts -> return (Just mod_guts)	-- No desugaring to do!
	}}
	 

261
hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
262 263 264
 	    -------------------
 	    -- DISPLAY PROGRESS MESSAGE
 	    -------------------
265 266 267
	; let dflags    = hsc_dflags hsc_env
	      one_shot  = isOneShot (ghcMode dflags)
	      toInterp  = hscTarget dflags == HscInterpreted
268
      	; when (not one_shot) $
269
		 compilationProgressMsg dflags $
270 271
		 (showModuleIndex mb_mod_index ++
                  "Compiling " ++ showModMsg (not toInterp) mod_summary)
sof's avatar
sof committed
272
			
273 274 275 276 277
 	    -------------------
 	    -- PARSE
 	    -------------------
	; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
	      hspp_buf  = ms_hspp_buf  mod_summary
278

279
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
280

281
	; case maybe_parsed of {
282
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
283 284
			    ; return Nothing } ;
      	     Right rdr_module -> do {
285

286 287 288 289
 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
290
		<- {-# SCC "Typecheck-Rename" #-}
291
		   tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
292

293
	; printErrorsAndWarnings dflags tc_msgs
294 295 296 297 298 299 300
	; case maybe_tc_result of {
      	     Nothing -> return Nothing ;
      	     Just tc_result -> do {

 	    -------------------
 	    -- DESUGAR
 	    -------------------
301
	; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
302
		 	     deSugar hsc_env tc_result
303
	; printBagOfWarnings dflags warns
304
	; return maybe_ds_result
305 306
	}}}}}

307 308
------------------------------

309 310
hscFileCheck :: HscEnv -> ModSummary -> IO HscResult
hscFileCheck hsc_env mod_summary = do {
311 312 313
 	    -------------------
 	    -- PARSE
 	    -------------------
314 315
	; let dflags    = hsc_dflags hsc_env
	      hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
316 317
	      hspp_buf  = ms_hspp_buf  mod_summary

318
	; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
319 320

	; case maybe_parsed of {
321
      	     Left err -> do { printBagOfErrors dflags (unitBag err)
322 323 324 325 326 327 328 329
			    ; return HscFail } ;
      	     Right rdr_module -> do {

 	    -------------------
 	    -- RENAME and TYPECHECK
 	    -------------------
	  (tc_msgs, maybe_tc_result) 
		<- _scc_ "Typecheck-Rename" 
330 331 332
		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
			True{-save renamed syntax-}
			rdr_module
333

334
	; printErrorsAndWarnings dflags tc_msgs
335
	; case maybe_tc_result of {
336
      	     Nothing -> return (HscChecked rdr_module Nothing Nothing);
337 338 339 340 341 342
      	     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"] }
343
				   -- Rules are CoreRules, not the
344
				   -- RuleDecls we get out of the typechecker
345 346 347 348
                    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)
349
		return (HscChecked rdr_module 
350
                                   rnInfo
351 352 353
				   (Just (tcg_binds tc_result,
					  tcg_rdr_env tc_result,
					  md)))
354
	}}}}
355

356 357 358 359
------------------------------
hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
-- For hs-boot files, there's no code generation to do

360
hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing 
361
  = return HscFail
362
hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
363
  = do	{ details <- mkBootModDetails hsc_env ds_result
364 365 366

	; (new_iface, no_change) 
		<- {-# SCC "MkFinalIface" #-}
367
		   mkIface hsc_env maybe_old_iface ds_result details
368 369

	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
370 371 372 373

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

374
	; return (HscRecomp details new_iface
375 376 377 378 379 380
                            False False Nothing)
 	}

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

381
hscBackEnd hsc_env mod_summary maybe_old_iface Nothing 
382 383
  = return HscFail

384
hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) 
385 386 387
  = do 	{ 	-- OMITTED: 
		-- ; seqList imported_modules (return ())

388
	  let one_shot  = isOneShot (ghcMode dflags)
389
	      dflags    = hsc_dflags hsc_env
390

chak's avatar
chak committed
391 392 393
 	    -------------------
 	    -- FLATTENING
 	    -------------------
394
	; flat_result <- {-# SCC "Flattening" #-}
395 396
 			 flatten hsc_env ds_result

397

398 399 400
{-	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
401 402

	; let 	-- Rule-base accumulated from imported packages
403
	     pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
404 405 406 407 408 409 410 411 412 413

		-- 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 ()
414
-}
415

416 417
	-- alive at this point:  
	--	pcs_middle
418
	--	flat_result
419
	--      pkg_rule_base
420

421
 	    -------------------
422 423
 	    -- SIMPLIFY
 	    -------------------
424
	; simpl_result <- {-# SCC "Core2Core" #-}
425
			  core2core hsc_env flat_result
426 427 428

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

433 434
	-- Alive at this point:  
	--	tidy_result, pcs_final
435
	--      hsc_env
436

437 438 439 440 441 442
 	    -------------------
	    -- 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
443 444 445
	; (new_iface, no_change)
		<- {-# SCC "MkFinalIface" #-}
		   mkIface hsc_env maybe_old_iface simpl_result details
446 447

	; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
448 449 450 451

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

	    -- Build the final ModDetails (except in one-shot mode, where
	    -- we won't need this information after compilation).
457 458 459 460 461
	; final_details <- if one_shot then return (error "no final details")
		 	   else return $! details

	-- Emit external core
	; emitExternalCore dflags cg_guts
462 463 464 465

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

468 469 470 471
      	  -- And the answer is ...
	; dumpIfaceStats hsc_env

	; return (HscRecomp final_details
472
			    final_iface
473
                            stub_h_exists stub_c_exists
474
      			    maybe_bcos)
475
      	 }
476 477


478

479
hscCodeGen dflags location
480
    CgGuts{  -- This is the last use of the ModGuts in a compilation.
481
	      -- From now on, we just use the bits we need.
482 483 484 485 486
        cg_module   = this_mod,
	cg_binds    = core_binds,
	cg_tycons   = tycons,
	cg_dir_imps = dir_imps,
	cg_foreign  = foreign_stubs,
487
	cg_home_mods = home_mods,
488 489 490 491 492
	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
493 494 495 496

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

500
  case hscTarget dflags of
501 502 503 504 505
      HscNothing -> return (False, False, Nothing)

      HscInterpreted ->
#ifdef GHCI
	do  -----------------  Generate byte code ------------------
506
	    comp_bc <- byteCodeGen dflags prepd_binds data_tycons
507 508 509
	
	    ------------------ Create f-x-dynamic C-side stuff ---
	    (istub_h_exists, istub_c_exists) 
510
	       <- outputForeignStubs dflags this_mod location foreign_stubs
511
	    
512
	    return ( istub_h_exists, istub_c_exists, Just comp_bc )
513 514 515 516 517 518 519
#else
	panic "GHC not compiled with interpreter"
#endif

      other ->
	do
	    -----------------  Convert to STG ------------------
520
	    (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-}
521
	    		 myCoreToStg dflags home_mods this_mod prepd_binds	
522 523

            ------------------  Code generation ------------------
524
	    abstractC <- {-# SCC "CodeGen" #-}
525 526 527
		         codeGen dflags home_mods this_mod data_tycons
				 foreign_stubs dir_imps cost_centre_info
				 stg_binds
528

529 530
	    ------------------  Code output -----------------------
	    (stub_h_exists, stub_c_exists)
531
		     <- codeOutput dflags this_mod location foreign_stubs 
532 533
				dependencies abstractC

534
	    return (stub_h_exists, stub_c_exists, Nothing)
535
   }
sof's avatar
sof committed
536

537

538 539
hscCmmFile :: DynFlags -> FilePath -> IO Bool
hscCmmFile dflags filename = do
540
  maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
541 542 543
  case maybe_cmm of
    Nothing -> return False
    Just cmm -> do
544
	codeOutput dflags no_mod no_loc NoStubs [] [cmm]
545 546 547
	return True
  where
	no_mod = panic "hscCmmFile: no_mod"
548 549 550
	no_loc = ModLocation{ ml_hs_file  = Just filename,
                              ml_hi_file  = panic "hscCmmFile: no hi file",
                              ml_obj_file = panic "hscCmmFile: no obj file" }
551 552


553
myParseModule dflags src_filename maybe_src_buf
554 555 556
 =    --------------------------  Parser  ----------------
      showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
557 558 559 560 561 562 563

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

565
      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
566

567
      case unP parseModule (mkPState buf loc dflags) of {
568

569
	PFailed span err -> return (Left (mkPlainErrMsg span err));
570

571
	POk _ rdr_module -> do {
572

573 574
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
575
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
576 577
			   (ppSourceStats False rdr_module) ;
      
578
      return (Right rdr_module)
579
	-- ToDo: free the string buffer later.
580
      }}
581 582


583
myCoreToStg dflags home_mods this_mod prepd_binds
584
 = do 
585
      stg_binds <- {-# SCC "Core2Stg" #-}
586
	     coreToStg home_mods prepd_binds
587

588
      (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
589
	     stg2stg dflags home_mods this_mod stg_binds
590

591
      return (stg_binds2, cost_centre_info)
592 593
\end{code}

594

595 596
%************************************************************************
%*									*
597
\subsection{Compiling a do-statement}
598 599 600
%*									*
%************************************************************************

601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622
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]
623

624 625 626 627
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
628 629 630 631
#ifdef GHCI
hscStmt		-- Compile a stmt all the way to an HValue, but don't run it
  :: HscEnv
  -> String			-- The statement
632
  -> IO (Maybe (HscEnv, [Name], HValue))
chak's avatar
chak committed
633

634
hscStmt hsc_env stmt
635 636
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
	; case maybe_stmt of {
637 638 639
      	     Nothing	  -> return Nothing ;	-- Parse error
      	     Just Nothing -> return Nothing ;	-- Empty line
      	     Just (Just parsed_stmt) -> do {	-- The real stuff
640

641
		-- Rename and typecheck it
642 643
	  let icontext = hsc_IC hsc_env
	; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
644

645
	; case maybe_tc_result of {
646
		Nothing -> return Nothing ;
647
		Just (new_ic, bound_names, tc_expr) -> do {
648

649
		-- Then desugar, code gen, and link it
650
	; hval <- compileExpr hsc_env iNTERACTIVE 
651 652 653
			      (ic_rn_gbl_env new_ic) 
			      (ic_type_env new_ic)
			      tc_expr
654

655
	; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
656
	}}}}}
657

658 659 660
hscTcExpr	-- Typecheck an expression (but don't run it)
  :: HscEnv
  -> String			-- The expression
661
  -> IO (Maybe Type)
662

663
hscTcExpr hsc_env expr
664
  = do	{ maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
665
	; let icontext = hsc_IC hsc_env
666
	; case maybe_stmt of {
667
	     Nothing      -> return Nothing ;	-- Parse error
668
	     Just (Just (L _ (ExprStmt expr _ _)))
669
			-> tcRnExpr hsc_env icontext expr ;
670
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
671
			        return Nothing } ;
672 673 674 675 676 677 678
      	     } }

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

679
hscKcType hsc_env str
680
  = do	{ maybe_type <- hscParseType (hsc_dflags hsc_env) str
681
	; let icontext = hsc_IC hsc_env
682 683
	; case maybe_type of {
	     Just ty	-> tcRnType hsc_env icontext ty ;
684
	     Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
685
			        return Nothing } ;
686
      	     Nothing    -> return Nothing } }
687
#endif
688
\end{code}
689

690
\begin{code}
691
#ifdef GHCI
692 693 694 695 696
hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
hscParseStmt = hscParseThing parseStmt

hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
hscParseType = hscParseThing parseType
697
#endif
698 699 700 701 702 703 704 705 706 707 708

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
709 710
 = showPass dflags "Parser" >>
      {-# SCC "Parser" #-} do
711

712
      buf <- stringToStringBuffer str
713

714
      let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
715

716
      case unP parser (mkPState buf loc dflags) of {
717

718 719
	PFailed span err -> do { printError span err;
                                 return Nothing };
720

721
	POk _ thing -> do {
722

723 724
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
725 726
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
      return (Just thing)
727 728
      }}
\end{code}
729

730 731
%************************************************************************
%*									*
732
	Desugar, simplify, convert to bytecode, and link an expression
733 734 735 736 737
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
738
compileExpr :: HscEnv 
739
	    -> Module -> GlobalRdrEnv -> TypeEnv
740
	    -> LHsExpr Id
741
	    -> IO HValue
742

743
compileExpr hsc_env this_mod rdr_env type_env tc_expr
744 745 746
  = do	{ let { dflags  = hsc_dflags hsc_env ;
		lint_on = dopt Opt_DoCoreLinting dflags }
	      
747
	 	-- Desugar it
748
	; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
749 750
	
		-- Flatten it
751
	; flat_expr <- flattenExpr hsc_env ds_expr
752

753 754
		-- Simplify it
	; simpl_expr <- simplifyExpr dflags flat_expr
755

756
		-- Tidy it (temporary, until coreSat does cloning)
757
	; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
758

759 760
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
761

762 763 764 765 766 767 768 769 770
		-- 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 ()

771 772
		-- Convert to BCOs
	; bcos <- coreExprToBCOs dflags prepd_expr
773

774
		-- link it
775
	; hval <- linkExpr hsc_env bcos
776

777 778
	; return hval
     }
779 780 781
#endif
\end{code}

782

783 784
%************************************************************************
%*									*
785
	Statistics on reading interfaces
786 787 788 789
%*									*
%************************************************************************

\begin{code}
790 791 792 793 794 795
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env
  = do	{ eps <- readIORef (hsc_EPS hsc_env)
	; dumpIfSet (dump_if_trace || dump_rn_stats)
	      	    "Interface statistics"
	      	    (ifaceStats eps) }
796
  where
797 798 799
    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
800
\end{code}
801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816

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

\begin{code}
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
    where
        n_str = show n
<