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
164
 = do {
      hPutStrLn stderr "compilation IS NOT required";
165
      let { bomb = panic "hscNoRecomp:OneShot" };
166
167
      return (HscNoRecomp pcs_ch bomb bomb)
      }
168
 | otherwise
169
 = do {
170
      when (verbosity dflags >= 1) $
171
172
		hPutStrLn stderr ("Skipping  " ++ 
			compMsg have_object mod location);
173

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

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

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

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

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

201

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

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

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

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

259
260
261
262
263
264
265
266
267
268
269
270
271
272
	; 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

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

 	    -------------------
 	    -- TIDY
282
 	    -------------------
283
284
285
286
287
288
289
290
291
292
293
294
	; 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) 
295
296
	     <- _scc_ "CoreTidy"
	        tidyCorePgm dflags this_mod pcs_middle cg_info simpl_details
297
      
298
299
300
301
302
303
304
	; 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
305
	; emitExternalCore dflags new_iface tidy_details 
306
 	    -------------------
307
 	    -- PREPARE FOR CODE GENERATION
308
 	    -------------------
309
	      -- Do saturation and convert to A-normal form
310
	; prepd_details <- _scc_ "CorePrep" corePrepPgm dflags tidy_details
311

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

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

	    (h_code,c_code,fe_binders) = foreign_stuff

328
        ; imported_modules <- mapM mod_name_to_Module imported_module_names
329

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

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

	        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
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
		    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)
382
383

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

385
386

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

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

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

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

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

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

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

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


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

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

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

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


450
451
\end{code}

452

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

565
566
567
568
     }}}}}

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

573
      buf <- stringToStringBuffer str
574

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

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

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

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

	POk _ (Just rdr_stmt) -> do {
590

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

600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
%************************************************************************
%*									*
\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
619
   = do maybe_rdr_name <- myParseIdentifier dflags str
620
621
622
623
624
625
626
627
628
629
630
631
632
633
	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
634
635

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

	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) }
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
        }}}

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) }
670
671
672
#endif
\end{code}

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

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

692
initPersistentRenamerState :: IO PersistentRenamerState
693
  = do us <- mkSplitUniqSupply 'r'
694
       return (
695
696
697
        PRS { prsOrig  = NameSupply { nsUniqs = us,
				      nsNames = initOrigNames,
			      	      nsIPs   = emptyFM },
698
699
	      prsDecls 	 = (emptyNameEnv, 0),
	      prsInsts 	 = (emptyBag, 0),
700
	      prsRules 	 = foldr add_rule (emptyBag, 0) builtinRules,
701
	      prsImpMods = emptyFM
702
703
            }
        )
704
705
706
707
708
709
710
711
  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
712

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