HscMain.lhs 22.5 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
rrt's avatar
rrt committed
10
		 hscStmt, hscThing,
11
#endif
12
		 initPersistentCompilerState ) where
13

14
#include "HsVersions.h"
15

16
#ifdef GHCI
17
import Interpreter
18
import ByteCodeGen	( byteCodeGen )
19
20
import CoreTidy		( tidyCoreExpr )
import CorePrep		( corePrepExpr )
21
import Rename		( renameStmt, renameRdrName )
22
import RdrName          ( rdrNameOcc, setRdrNameOcc )
23
import RdrHsSyn		( RdrNameStmt )
24
25
import OccName          ( dataName, tcClsName, 
			  occNameSpace, setOccNameSpace )
26
import Type		( Type )
27
import Id		( Id, idName, setGlobalIdDetails )
28
import IdInfo		( GlobalIdDetails(VanillaGlobal) )
29
import HscTypes		( InteractiveContext(..) )
30
import PrelNames	( iNTERACTIVE )
31
import StringBuffer	( stringToStringBuffer )
rrt's avatar
rrt committed
32
import FastString       ( mkFastString )
33
import Maybes		( catMaybes )
34
35
#endif

36
37
import HsSyn

38
import RdrName		( mkRdrOrig )
39
40
41
import Id		( idName )
import IdInfo		( CafInfo(..), CgInfoEnv, CgInfo(..) )
import StringBuffer	( hGetStringBuffer, freeStringBuffer )
42
import Parser
43
import Lex		( PState(..), ParseResult(..) )
44
import SrcLoc		( mkSrcLoc )
45
import Finder		( findModule )
46
import Rename		( checkOldIface, renameModule, closeIfaceDecls )
47
import Rules		( emptyRuleBase )
48
import PrelInfo		( wiredInThingEnv, wiredInThings )
49
import PrelRules	( builtinRules )
50
import PrelNames	( knownKeyNames )
51
import MkIface		( mkFinalIface )
52
import TcModule
53
import InstEnv		( emptyInstEnv )
54
55
import Desugar
import SimplCore
56
import CoreUtils	( coreBindsSize )
57
import CoreTidy		( tidyCorePgm )
58
59
import CorePrep		( corePrepPgm )
import StgSyn
60
import CoreToStg	( coreToStg )
61
62
import SimplStg		( stg2stg )
import CodeGen		( codeGen )
63
import CodeOutput	( codeOutput )
64

65
66
import Module		( ModuleName, moduleName, mkHomeModule, 
			  moduleUserString )
67
import CmdLineOpts
68
import ErrUtils		( dumpIfSet_dyn, showPass, printError )
69
import Util		( unJust )
70
import UniqSupply	( mkSplitUniqSupply )
71

72
import Bag		( consBag, emptyBag )
73
import Outputable
74
import HscStats		( ppSourceStats )
75
import HscTypes
76
import FiniteMap	( FiniteMap, plusFM, emptyFM, addToFM )
77
import OccName		( OccName )
78
import Name		( Name, nameModule, nameOccName, getName, isGlobalName )
79
import NameEnv		( emptyNameEnv, mkNameEnv )
80
import Module		( Module )
81
82

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

84
import Monad		( when )
85
import Maybe		( isJust, fromJust )
86
import IO
apt's avatar
apt committed
87
88

import MkExternalCore	( emitExternalCore )
89
90
\end{code}

91
92
93
94
95
96
97

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

98
\begin{code}
99
data HscResult
100
101
102
103
104
105
106
107
108
109
   -- 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)
110
111
	         Bool	 	 	-- stub_h exists
	         Bool  		 	-- stub_c exists
ken's avatar
ken committed
112
#ifdef GHCI
113
	         (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
ken's avatar
ken committed
114
115
116
#else
	         (Maybe ())			 -- no interpreted code whatsoever
#endif
117

118
119
	-- no errors or warnings; the individual passes
	-- (parse/rename/typecheck) print messages themselves
120

121
hscMain
122
123
  :: GhciMode
  -> DynFlags
124
  -> Module
125
  -> ModuleLocation		-- location info
126
127
  -> Bool			-- True <=> source unchanged
  -> Bool			-- True <=> have an object file (for msgs only)
128
  -> Maybe ModIface		-- old interface, if available
129
  -> HomeSymbolTable		-- for home module ModDetails
130
  -> HomeIfaceTable
131
  -> PersistentCompilerState    -- IN: persistent compiler state
132
  -> IO HscResult
133

134
135
hscMain ghci_mode dflags mod location source_unchanged have_object 
	maybe_old_iface hst hit pcs
136
 = do {
137
138
139
      showPass dflags ("Checking old interface for hs = " 
			++ show (ml_hs_file location)
                	++ ", hspp = " ++ show (ml_hspp_file location));
140

141
      (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
142
         <- _scc_ "checkOldIface"
143
	    checkOldIface ghci_mode dflags hit hst pcs (ml_hi_file location)
144
		source_unchanged maybe_old_iface;
145
146

      if errs_found then
147
         return (HscFail pcs_ch)
148
      else do {
149

150
151
152
      let no_old_iface = not (isJust maybe_checked_iface)
          what_next | recomp_reqd || no_old_iface = hscRecomp 
                    | otherwise                   = hscNoRecomp
153
      ;
154
155
      what_next ghci_mode dflags have_object mod location 
		maybe_checked_iface hst hit pcs_ch
156
      }}
157
158


159
-- we definitely expect to have the old interface available
160
161
hscNoRecomp ghci_mode dflags have_object 
	    mod location (Just old_iface) hst hit pcs_ch
162
 | ghci_mode == OneShot
163
 = do {
164
165
      when (verbosity dflags > 0) $
	  hPutStrLn stderr "compilation IS NOT required";
166
      let { bomb = panic "hscNoRecomp:OneShot" };
167
168
      return (HscNoRecomp pcs_ch bomb bomb)
      }
169
 | otherwise
170
 = do {
171
      when (verbosity dflags >= 1) $
172
173
		hPutStrLn stderr ("Skipping  " ++ 
			compMsg have_object mod location);
174

175
176
      -- CLOSURE
      (pcs_cl, closure_errs, cl_hs_decls) 
177
         <- closeIfaceDecls dflags hit hst pcs_ch old_iface ;
178
      if closure_errs then 
179
         return (HscFail pcs_cl) 
180
181
182
      else do {

      -- TYPECHECK
183
      maybe_tc_result 
184
	<- typecheckIface dflags pcs_cl hst old_iface cl_hs_decls;
185

186
      case maybe_tc_result of {
187
         Nothing -> return (HscFail pcs_cl);
188
         Just (pcs_tc, new_details) ->
189

190
      return (HscNoRecomp pcs_tc new_details old_iface)
191
      }}}
192

193
compMsg use_object mod location =
194
    mod_str ++ take (max 0 (16 - length mod_str)) (repeat ' ')
195
196
197
198
199
    ++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
    ++ (if use_object
	  then unJust "hscRecomp" (ml_obj_file location)
	  else "interpreted")
    ++ " )"
200
201
 where mod_str = moduleUserString mod

202

203
204
hscRecomp ghci_mode dflags have_object 
	  mod location maybe_checked_iface hst hit pcs_ch
205
206
207
 = do	{
      	  -- what target are we shooting for?
      	; let toInterp = dopt_HscLang dflags == HscInterpreted
apt's avatar
apt committed
208
	; let toNothing = dopt_HscLang dflags == HscNothing
209

210
211
212
213
      	; when (verbosity dflags >= 1) $
		hPutStrLn stderr ("Compiling " ++ 
			compMsg (not toInterp) mod location);

214
215
216
 	    -------------------
 	    -- PARSE
 	    -------------------
217
218
	; maybe_parsed <- myParseModule dflags 
                             (unJust "hscRecomp:hspp" (ml_hspp_file location))
219
220
221
	; case maybe_parsed of {
      	     Nothing -> return (HscFail pcs_ch);
      	     Just rdr_module -> do {
222
	; let this_mod = mkHomeModule (hsModuleName rdr_module)
223
224
225
226
    
 	    -------------------
 	    -- RENAME
 	    -------------------
227
	; (pcs_rn, print_unqualified, maybe_rn_result) 
228
229
      	     <- _scc_ "Rename" 
		 renameModule dflags hit hst pcs_ch this_mod rdr_module
230
      	; case maybe_rn_result of {
231
      	     Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
232
      	     Just (is_exported, new_iface, rn_hs_decls) -> do {
233
    
234
235
236
237
238
239
240
241
242
 	    -- 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

243
244
245
 	    -------------------
 	    -- TYPECHECK
 	    -------------------
246
247
	; maybe_tc_result 
	    <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface 
248
					     print_unqualified rn_hs_decls 
249
	; case maybe_tc_result of {
250
      	     Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
251
      	     Just (pcs_tc, tc_result) -> do {
252
253
    
 	    -------------------
254
255
 	    -- DESUGAR
 	    -------------------
256
	; (ds_details, foreign_stuff) 
257
258
             <- _scc_ "DeSugar" 
		deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
259

260
261
262
263
264
265
266
267
268
269
270
271
272
273
	; pcs_middle
	    <- if ghci_mode == OneShot 
		  then do init_pcs <- initPersistentCompilerState
			  init_prs <- initPersistentRenamerState
		          let 
			      rules   = pcs_rules pcs_tc	
			      orig_tc = prsOrig (pcs_PRS pcs_tc)
			      new_prs = init_prs{ prsOrig=orig_tc }

			  orig_tc `seq` rules `seq` new_prs `seq`
			    return init_pcs{ pcs_PRS = new_prs,
			                     pcs_rules = rules }
		  else return pcs_tc

274
 	    -------------------
275
276
 	    -- SIMPLIFY
 	    -------------------
277
	; simpl_details
278
	     <- _scc_     "Core2Core"
279
		core2core dflags pcs_middle hst dont_discard ds_details
280
281
282

 	    -------------------
 	    -- TIDY
283
 	    -------------------
284
285
286
287
288
289
290
291
292
293
294
295
	; 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) 
296
297
	     <- _scc_ "CoreTidy"
	        tidyCorePgm dflags this_mod pcs_middle cg_info simpl_details
298
      
299
300
301
302
303
304
305
	; pcs_final <- if ghci_mode == OneShot then initPersistentCompilerState
				   	       else return pcs_simpl

	-- alive at this point:  
	--	tidy_details
	--	new_iface		

apt's avatar
apt committed
306
	; emitExternalCore dflags new_iface tidy_details 
307
 	    -------------------
308
 	    -- PREPARE FOR CODE GENERATION
309
 	    -------------------
310
	      -- Do saturation and convert to A-normal form
311
	; prepd_details <- _scc_ "CorePrep" corePrepPgm dflags tidy_details
312

313
 	    -------------------
314
 	    -- CONVERT TO STG and COMPLETE CODE GENERATION
315
 	    -------------------
316
317
318
319
320
321
322
	; 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)
323
324
325

	    mod_name_to_Module nm
		 = do m <- findModule nm ; return (fst (fromJust m))
326
327
328

	    (h_code,c_code,fe_binders) = foreign_stuff

329
        ; imported_modules <- mapM mod_name_to_Module imported_module_names
330

331
	; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
332
	   <- if toInterp
ken's avatar
ken committed
333
#ifdef GHCI
334
335
336
337
338
339
340
341
342
343
344
345
346
	        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

347
      		    return ( False, False, Just (bcos,itbl_env), final_iface )
ken's avatar
ken committed
348
349
350
#else
		then error "GHC not compiled with interpreter"
#endif
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

	        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

apt's avatar
apt committed
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
		    if toNothing 
                      then do
			  return (False, False, Nothing, final_iface)
	              else do
		          ------------------  Code generation ------------------
			  abstractC <- _scc_ "CodeGen"
					codeGen dflags this_mod imported_modules
					       cost_centre_info fe_binders
					       local_tycons stg_binds
			  
			  ------------------  Code output -----------------------
			  (stub_h_exists, stub_c_exists)
			     <- codeOutput dflags this_mod local_tycons
				   binds stg_binds
				   c_code h_code abstractC
			      
			  return (stub_h_exists, stub_c_exists, Nothing, final_iface)
383
384

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

386
387

      	  -- and the answer is ...
388
	; return (HscRecomp pcs_final
389
390
			    final_details
			    final_iface
391
                            stub_h_exists stub_c_exists
392
      			    maybe_bcos)
393
      	  }}}}}}}
394

395
myParseModule dflags src_filename
396
 = do --------------------------  Parser  ----------------
397
      showPass dflags "Parser"
398
      _scc_  "Parser" do
399
400

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

402
      let glaexts | dopt Opt_GlasgowExts dflags = 1#
403
	          | otherwise 		        = 0#
404

405
406
407
      case parseModule buf PState{ bol = 0#, atbol = 1#,
	 		           context = [], glasgow_exts = glaexts,
  			           loc = mkSrcLoc (_PK_ src_filename) 1 } of {
408

409
	PFailed err -> do { hPutStrLn stderr (showSDoc err);
410
                            freeStringBuffer buf;
411
                            return Nothing };
412

413
	POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
414

415
416
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
      
417
      dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
418
419
			   (ppSourceStats False rdr_module) ;
      
420
      return (Just rdr_module)
421
	-- ToDo: free the string buffer later.
422
      }}
423
424


425
myCoreToStg dflags this_mod tidy_binds
426
 = do 
427
      () <- coreBindsSize tidy_binds `seq` return ()
428
429
430
431
      -- TEMP: the above call zaps some space usage allocated by the
      -- simplifier, which for reasons I don't understand, persists
      -- thoroughout code generation

432
      stg_binds <- _scc_ "Core2Stg" coreToStg dflags tidy_binds
433

434
435
      (stg_binds2, cost_centre_info)
	   <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
436

437
438
439
440
441
442
443
444
445
      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)
446
   where
447
448
      stgBindPairs (StgNonRec _ b r) = [(b,r)]
      stgBindPairs (StgRec    _ prs) = prs
apt's avatar
apt committed
449
450


451
452
\end{code}

453

454
455
%************************************************************************
%*									*
456
\subsection{Compiling a do-statement}
457
458
459
%*									*
%************************************************************************

460
\begin{code}
461
#ifdef GHCI
462
hscStmt
463
464
465
466
  :: DynFlags
  -> HomeSymbolTable	
  -> HomeIfaceTable
  -> PersistentCompilerState    -- IN: persistent compiler state
467
468
  -> InteractiveContext		-- Context for compiling
  -> String			-- The statement
469
  -> Bool			-- just treat it as an expression
470
  -> IO ( PersistentCompilerState, 
471
	  Maybe ( [Id], 
472
473
		  Type, 
		  UnlinkedBCOExpr) )
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
\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]
498

499
500
501
502
	expr (of non-IO type, 
	  result not showable)	==>	error

\begin{code}
503
hscStmt dflags hst hit pcs0 icontext stmt just_expr
504
   =  do { maybe_stmt <- hscParseStmt dflags stmt
505
	; case maybe_stmt of
506
      	     Nothing -> return (pcs0, Nothing)
507
      	     Just parsed_stmt -> do {
508

509
510
	   let { notExprStmt (ExprStmt _ _ _) = False;
	         notExprStmt _                = True 
511
512
513
514
515
516
517
	       };

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

518
		-- Rename it
519
	  (pcs1, print_unqual, maybe_renamed_stmt)
520
521
		 <- renameStmt dflags hit hst pcs0 
			iNTERACTIVE icontext parsed_stmt
522

523
524
525
	; case maybe_renamed_stmt of
		Nothing -> return (pcs0, Nothing)
		Just (bound_names, rn_stmt) -> do {
526

527
		-- Typecheck it
528
529
	  maybe_tc_return <- 
	    if just_expr 
sof's avatar
sof committed
530
		then case rn_stmt of { (ExprStmt e _ _, decls) -> 
531
		     typecheckExpr dflags pcs1 hst (ic_type_env icontext)
sof's avatar
sof committed
532
			   print_unqual iNTERACTIVE (e,decls) }
533
		else typecheckStmt dflags pcs1 hst (ic_type_env icontext)
sof's avatar
sof committed
534
			   print_unqual iNTERACTIVE bound_names rn_stmt
535
536
537
538

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

540
		-- Desugar it
541
	  ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
542
543
	
		-- Simplify it
544
	; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr
545

546
547
548
		-- Tidy it (temporary, until coreSat does cloning)
	; tidy_expr <- tidyCoreExpr simpl_expr

549
550
		-- Prepare for codegen
	; prepd_expr <- corePrepExpr dflags tidy_expr
551

552
		-- Convert to BCOs
553
	; bcos <- coreExprToBCOs dflags prepd_expr
554
555

	; let
556
		-- Make all the bound ids "global" ids, now that
557
558
559
560
		-- 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.
561
	     global_bound_ids = map globaliseId bound_ids;
562
	     globaliseId id   = setGlobalIdDetails id VanillaGlobal
563

564
	; return (pcs2, Just (global_bound_ids, ty, bcos))
565

566
567
568
569
     }}}}}

hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
hscParseStmt dflags str
570
571
 = do --------------------------  Parser  ----------------
      showPass dflags "Parser"
572
      _scc_ "Parser" do
573

574
      buf <- stringToStringBuffer str
575

576
      let glaexts | dopt Opt_GlasgowExts dflags = 1#
577
       	          | otherwise  	                = 0#
578

579
      case parseStmt buf PState{ bol = 0#, atbol = 1#,
580
	 		         context = [], glasgow_exts = glaexts,
581
			         loc = mkSrcLoc SLIT("<interactive>") 1 } of {
582

583
	PFailed err -> do { hPutStrLn stderr (showSDoc err);
584
--	Not yet implemented in <4.11    freeStringBuffer buf;
585
                            return Nothing };
586

587
588
589
590
	-- no stmt: the line consisted of just space or comments
	POk _ Nothing -> return Nothing;

	POk _ (Just rdr_stmt) -> do {
591

592
593
594
      --ToDo: can't free the string buffer until we've finished this
      -- compilation sweep and all the identifiers have gone away.
      --freeStringBuffer buf;
595
596
      dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt);
      return (Just rdr_stmt)
597
      }}
598
#endif
599
\end{code}
600

601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
%************************************************************************
%*									*
\subsection{Getting information about an identifer}
%*									*
%************************************************************************

\begin{code}
#ifdef GHCI
hscThing -- like hscStmt, but deals with a single identifier
  :: DynFlags
  -> HomeSymbolTable
  -> HomeIfaceTable
  -> PersistentCompilerState    -- IN: persistent compiler state
  -> InteractiveContext		-- Context for compiling
  -> String			-- The identifier
  -> IO ( PersistentCompilerState,
	  [TyThing] )

hscThing dflags hst hit pcs0 icontext str
620
   = do maybe_rdr_name <- myParseIdentifier dflags str
621
622
623
624
625
626
627
628
629
630
631
632
633
634
	case maybe_rdr_name of {
	  Nothing -> return (pcs0, []);
	  Just rdr_name -> do

	-- if the identifier is a constructor (begins with an
	-- upper-case letter), then we need to consider both
	-- constructor and type class identifiers.
	let rdr_names
		| occNameSpace occ == dataName = [ rdr_name, tccls_name ]
		| otherwise                    = [ rdr_name ]
	      where
		occ        = rdrNameOcc rdr_name
		tccls_occ  = setOccNameSpace occ tcClsName
		tccls_name = setRdrNameOcc rdr_name tccls_occ
635
636

	(pcs, unqual, maybe_rn_result) <- 
637
	   renameRdrName dflags hit hst pcs0 iNTERACTIVE icontext rdr_names
638
639
640
641
642
643
644
645
646
647
648
649
650
651

	case maybe_rn_result of {
	     Nothing -> return (pcs, []);
	     Just (names, decls) -> do {

	maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual
		   	iNTERACTIVE decls;

	case maybe_pcs of {
	     Nothing -> return (pcs, []);
	     Just pcs ->
		let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names
		in
		return (pcs, catMaybes maybe_ty_things) }
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
        }}}

myParseIdentifier dflags str
  = do buf <- stringToStringBuffer str
 
       let glaexts | dopt Opt_GlasgowExts dflags = 1#
		   | otherwise			 = 0#

       case parseIdentifier buf 
		PState{ bol = 0#, atbol = 1#,
 		        context = [], glasgow_exts = glaexts,
		        loc = mkSrcLoc SLIT("<interactive>") 1 } of

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

	  POk _ rdr_name -> do { --should, but can't: freeStringBuffer buf;
			         return (Just rdr_name) }
671
672
673
#endif
\end{code}

674
675
676
677
678
679
680
%************************************************************************
%*									*
\subsection{Initial persistent state}
%*									*
%************************************************************************

\begin{code}
681
initPersistentCompilerState :: IO PersistentCompilerState
682
initPersistentCompilerState 
683
684
  = do prs <- initPersistentRenamerState
       return (
685
        PCS { pcs_PIT   = emptyIfaceTable,
686
              pcs_PTE   = wiredInThingEnv,
687
	      pcs_insts = emptyInstEnv,
688
	      pcs_rules = emptyRuleBase,
689
	      pcs_PRS   = prs
690
691
            }
        )
692

693
initPersistentRenamerState :: IO PersistentRenamerState
694
  = do us <- mkSplitUniqSupply 'r'
695
       return (
696
697
698
        PRS { prsOrig  = NameSupply { nsUniqs = us,
				      nsNames = initOrigNames,
			      	      nsIPs   = emptyFM },
699
700
	      prsDecls 	 = (emptyNameEnv, 0),
	      prsInsts 	 = (emptyBag, 0),
701
	      prsRules 	 = foldr add_rule (emptyBag, 0) builtinRules,
702
	      prsImpMods = emptyFM
703
704
            }
        )
705
706
707
708
709
710
711
712
  where
    add_rule (name,rule) (rules, n_rules)
	 = (gated_decl `consBag` rules, n_rules+1)
	where
	   gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
	   mod	      = nameModule name
	   rdr_name   = mkRdrOrig (moduleName mod) (nameOccName name)
	   gate_fn vis_fn = vis_fn name	-- Load the rule whenever name is visible
713

714
initOrigNames :: FiniteMap (ModuleName,OccName) Name
715
716
717
718
719
720
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
721
\end{code}