StgInterp.lhs 48 KB
Newer Older
1
2
3
4
5
6
7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
%
\section[StgInterp]{Translates STG syntax to interpretable form, and run it}

\begin{code}

8
module StgInterp ( 
9
10

    ClosureEnv, ItblEnv, 
11
    filterNameMap,      -- :: [ModuleName] -> FiniteMap Name a 
12
			-- -> FiniteMap Name a
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

    linkIModules, 	-- :: ItblEnv -> ClosureEnv
	     		-- -> [([UnlinkedIBind], ItblEnv)]
	     		-- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)

    iExprToHValue,	--  :: ItblEnv -> ClosureEnv 
			--  -> UnlinkedIExpr -> HValue

    stgBindsToInterpSyn,-- :: [StgBinding] 
	       		-- -> [TyCon] -> [Class] 
	       		-- -> IO ([UnlinkedIBind], ItblEnv)

    stgExprToInterpSyn, -- :: StgExpr
	       		-- -> IO UnlinkedIExpr

    interp		-- :: LinkedIExpr -> HValue
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 ) where

{- -----------------------------------------------------------------------------

 ToDo:
   - link should be in the IO monad, so it can modify the symtabs as it
     goes along
 
   - need a way to remove the bindings for a module from the symtabs. 
     maybe the symtabs should be indexed by module first.

   - change the representation to something less verbose (?).

   - converting string literals to Addr# is horrible and introduces
     a memory leak.  See if something can be done about this.

45
46
   - lots of assumptions about word size vs. double size etc.

47
----------------------------------------------------------------------------- -}
48
49
50

#include "HsVersions.h"

51
52


53
import Linker
54
55
56
57
58
59
60
61
62
import Id 		( Id, idPrimRep )
import Outputable
import Var
import PrimOp		( PrimOp(..) )
import PrimRep		( PrimRep(..) )
import Literal		( Literal(..) )
import Type		( Type, typePrimRep, deNoteType, repType, funResultTy )
import DataCon		( DataCon, dataConTag, dataConRepArgTys )
import ClosureInfo	( mkVirtHeapOffsets )
63
64
import Module		( ModuleName, moduleName )
import RdrName
65
import Name		hiding (filterNameEnv)
66
import Util
67
68
import UniqFM
import UniqSet
69

70
--import {-# SOURCE #-} MCI_make_constr
71

72
import FastString
73
74
import GlaExts		( Int(..) )
import Module		( moduleNameFS )
75

76
import TyCon		( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
77
import Class		( Class, classTyCon )
78
79
80
import InterpSyn
import StgSyn
import FiniteMap
81
import OccName		( occNameString )
82
83
import ErrUtils		( showPass, dumpIfSet_dyn )
import CmdLineOpts	( DynFlags, DynFlag(..) )
84
import Panic		( panic )
85

86
87
88
import IOExts
import Addr
import Bits
89
90
import Foreign
import CTypes
91

92
import IO
93

94
95
96
97
98
import PrelGHC		--( unsafeCoerce#, dataToTag#,
			--  indexPtrOffClosure#, indexWordOffClosure# )
import PrelAddr 	( Addr(..) )
import PrelFloat	( Float(..), Double(..) )

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118

#if 1
interp = panic "interp"
stgExprToInterpSyn = panic "stgExprToInterpSyn"
stgBindsToInterpSyn = panic "stgBindsToInterpSyn"
iExprToHValue = panic "iExprToHValue"
linkIModules = panic "linkIModules"
filterNameMap = panic "filterNameMap"
type ItblEnv    = FiniteMap Name (Ptr StgInfoTable)
type ClosureEnv = FiniteMap Name HValue
data StgInfoTable = StgInfoTable {
   ptrs :: Word16,
   nptrs :: Word16,
   srtlen :: Word16,
   tipe :: Word16,
   code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
}

#else

119
120
121
122
-- ---------------------------------------------------------------------------
-- Environments needed by the linker
-- ---------------------------------------------------------------------------

123
124
type ItblEnv    = FiniteMap Name (Ptr StgInfoTable)
type ClosureEnv = FiniteMap Name HValue
125
emptyClosureEnv = emptyFM
126

127
-- remove all entries for a given set of modules from the environment
128
129
filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
filterNameMap mods env 
130
   = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
131

132
-- ---------------------------------------------------------------------------
133
-- Turn an UnlinkedIExpr into a value we can run, for the interpreter
134
135
-- ---------------------------------------------------------------------------

136
iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
137
138
139
iExprToHValue ie ce expr
   = do linked_expr <- linkIExpr ie ce expr
	return (interp linked_expr)
140

141
142
143
-- ---------------------------------------------------------------------------
-- Convert STG to an unlinked interpretable
-- ---------------------------------------------------------------------------
144

145
-- visible from outside
146
147
148
149
150
151
152
stgBindsToInterpSyn :: DynFlags
		    -> [StgBinding] 
	            -> [TyCon] -> [Class] 
	            -> IO ([UnlinkedIBind], ItblEnv)
stgBindsToInterpSyn dflags binds local_tycons local_classes
 = do showPass dflags "StgToInterp"
      let ibinds = concatMap (translateBind emptyUniqSet) binds
153
      let tycs   = local_tycons ++ map classTyCon local_classes
154
155
      dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
	 "Convert To InterpSyn" (vcat (map pprIBind ibinds))
156
      itblenv <- mkITbls tycs
157
158
      return (ibinds, itblenv)

159
160
161
162
163
stgExprToInterpSyn :: DynFlags
		   -> StgExpr
	           -> IO UnlinkedIExpr
stgExprToInterpSyn dflags expr
 = do showPass dflags "StgToInterp"
164
165
166
167
      let iexpr = stg2expr emptyUniqSet expr
      dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
	"Convert To InterpSyn" (pprIExpr iexpr)
      return iexpr
168
169
170
171

translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
translateBind ie (StgNonRec v e)  = [IBind v (rhs2expr ie e)]
translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
172
  where ie' = addListToUniqSet ie (map fst vs_n_es)
173
174
175
176

isRec (StgNonRec _ _) = False
isRec (StgRec _)      = True

177
rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
178
179
180
rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
   = mkLambdas args
     where
181
        rhsExpr = stg2expr (addListToUniqSet ie args) rhs
182
183
        rhsRep  = repOfStgExpr rhs
        mkLambdas [] = rhsExpr
184
185
	mkLambdas [v] = mkLam (repOfId v) rhsRep v rhsExpr
        mkLambdas (v:vs) = mkLam (repOfId v) RepP v (mkLambdas vs)
186
187
188
rhs2expr ie (StgRhsCon ccs dcon args)
   = conapp2expr ie dcon args

189
conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
190
conapp2expr ie dcon args
191
   = mkConApp con_rdrname reps exprs
192
     where
193
	con_rdrname = getName dcon
194
        exprs       = map (arg2expr ie) inHeapOrder
195
196
197
198
199
200
201
202
203
204
205
206
        reps        = map repOfArg inHeapOrder
        inHeapOrder = toHeapOrder args

        toHeapOrder :: [StgArg] -> [StgArg]
        toHeapOrder args
           = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
                 (rearranged, offsets) = unzip rearranged_w_offsets
             in
                 rearranged

-- Handle most common cases specially; do the rest with a generic
-- mechanism (deferred till later :)
207
mkConApp :: Name -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
208
209
210
211
mkConApp nm []               []         = ConApp    nm
mkConApp nm [RepI]           [a1]       = ConAppI   nm a1
mkConApp nm [RepP]           [a1]       = ConAppP   nm a1
mkConApp nm [RepP,RepP]      [a1,a2]    = ConAppPP  nm a1 a2
212
mkConApp nm reps args  = ConAppGen nm args
213
214
215
216
217

mkLam RepP RepP = LamPP
mkLam RepI RepP = LamIP
mkLam RepP RepI = LamPI
mkLam RepI RepI = LamII
218
mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
219
220
221
222
223

mkApp RepP RepP = AppPP
mkApp RepI RepP = AppIP
mkApp RepP RepI = AppPI
mkApp RepI RepI = AppII
224
mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
225
226
227
228
229
230

repOfId :: Id -> Rep
repOfId = primRep2Rep . idPrimRep

primRep2Rep primRep
   = case primRep of
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251

	-- genuine lifted types
        PtrRep        -> RepP

	-- all these are unboxed, fit into a word, and we assume they
	-- all have the same call/return convention.
        IntRep        -> RepI
	CharRep       -> RepI
	WordRep       -> RepI
	AddrRep       -> RepI
	WeakPtrRep    -> RepI
	StablePtrRep  -> RepI

	-- these are pretty dodgy: really pointers, but
	-- we can't let the compiler build thunks with these reps.
	ForeignObjRep -> RepP
	StableNameRep -> RepP
	ThreadIdRep   -> RepP
	ArrayRep      -> RepP
	ByteArrayRep  -> RepP

252
253
254
	FloatRep      -> RepF
	DoubleRep     -> RepD

255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
        other -> pprPanic "primRep2Rep" (ppr other)

repOfStgExpr :: StgExpr -> Rep
repOfStgExpr stgexpr
   = case stgexpr of
        StgLit lit 
           -> repOfLit lit
        StgCase scrut live liveR bndr srt alts
           -> case altRhss alts of
                 (a:_) -> repOfStgExpr a
                 []    -> panic "repOfStgExpr: no alts"
        StgApp var []
           -> repOfId var
        StgApp var args
           -> repOfApp ((deNoteType.repType.idType) var) (length args)

        StgPrimApp op args res_ty
           -> (primRep2Rep.typePrimRep) res_ty

        StgLet binds body -> repOfStgExpr body
        StgLetNoEscape live liveR binds body -> repOfStgExpr body

        StgConApp con args -> RepP -- by definition

        other 
           -> pprPanic "repOfStgExpr" (ppr other)
     where
282
        altRhss (StgAlgAlts tycon alts def)
283
           = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
284
        altRhss (StgPrimAlts tycon alts def)
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
           = [rhs | (lit,rhs) <- alts] ++ defRhs def
        defRhs StgNoDefault 
           = []
        defRhs (StgBindDefault rhs)
           = [rhs]

        -- returns the Rep of the result of applying ty to n args.
        repOfApp :: Type -> Int -> Rep
        repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
        repOfApp ty n = repOfApp (funResultTy ty) (n-1)



repOfLit lit
   = case lit of
300
301
302
303
304
305
306
        MachInt _    -> RepI
        MachWord _   -> RepI
        MachAddr _   -> RepI
        MachChar _   -> RepI
        MachFloat _  -> RepF
        MachDouble _ -> RepD
        MachStr _    -> RepI   -- because it's a ptr outside the heap
307
308
        other -> pprPanic "repOfLit" (ppr lit)

309
lit2expr :: Literal -> UnlinkedIExpr
310
311
lit2expr lit
   = case lit of
312
313
314
315
316
317
        MachInt  i   -> case fromIntegral i of I# i -> LitI i
        MachWord i   -> case fromIntegral i of I# i -> LitI i
        MachAddr i   -> case fromIntegral i of I# i -> LitI i
	MachChar i   -> case fromIntegral i of I# i -> LitI i
	MachFloat f  -> case fromRational f of F# f -> LitF f
	MachDouble f -> case fromRational f of D# f -> LitD f
318
319
320
321
322
323
324
325
326
327
        MachStr s    -> 
	   case s of
     		CharStr s i -> LitI (addr2Int# s)

		FastString _ l ba -> 
		-- sigh, a string in the heap is no good to us.  We need a 
		-- static C pointer, since the type of a string literal is 
		-- Addr#.  So, copy the string into C land and introduce a 
		-- memory leak at the same time.
		  let n = I# l in
328
329
330
331
332
		 -- CAREFUL!  Chars are 32 bits in ghc 4.09+
		  case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
				 	   strncpy a ba (fromIntegral n)
				 	   writeCharOffAddr addr n '\0'
				 	   return addr)
333
334
335
336
		  of  A# a -> LitI (addr2Int# a)

     		_ -> error "StgInterp.lit2expr: unhandled string constant type"

337
338
        other -> pprPanic "lit2expr" (ppr lit)

339
stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
340
341
342
stg2expr ie stgexpr
   = case stgexpr of
        StgApp var []
343
344
           -> mkVar ie (repOfId var) var

345
        StgApp var args
346
           -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
347
348
349
350
351
352
353
        StgLit lit
           -> lit2expr lit

        StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
           |  repOfStgExpr scrut /= RepP
           -> mkCasePrim (repOfStgExpr stgexpr) 
                         bndr (stg2expr ie scrut) 
354
355
                              (map (doPrimAlt ie') alts) 
                              (def2expr ie' def)
356
357
           | otherwise ->
		pprPanic "stg2expr(StgCase,prim)" (ppr (repOfStgExpr scrut) $$ (case scrut of (StgApp v _) -> ppr v <+> ppr (idType v) <+> ppr (idPrimRep v)) $$ ppr stgexpr)
358
	   where ie' = addOneToUniqSet ie bndr
359

360
        StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
361
362
363
           |  repOfStgExpr scrut == RepP
           -> mkCaseAlg (repOfStgExpr stgexpr) 
                        bndr (stg2expr ie scrut) 
364
365
366
                             (map (doAlgAlt ie') alts) 
                             (def2expr ie' def)
	   where ie' = addOneToUniqSet ie bndr
367

368

369
        StgPrimApp op args res_ty
370
           -> mkPrimOp (repOfStgExpr stgexpr) op (map (arg2expr ie) args)
371
372
373
374

        StgConApp dcon args
           -> conapp2expr ie dcon args

375
376
        StgLet binds@(StgNonRec v e) body
	   -> mkNonRec (repOfStgExpr stgexpr) 
377
		(head (translateBind ie binds)) 
378
379
380
381
		(stg2expr (addOneToUniqSet ie v) body)

        StgLet binds@(StgRec bs) body
           -> mkRec (repOfStgExpr stgexpr) 
382
		(translateBind ie binds) 
383
		(stg2expr (addListToUniqSet ie (map fst bs)) body)
384

385
386
387
388
389
	-- treat let-no-escape just like let.
	StgLetNoEscape _ _ binds body
	   -> stg2expr ie (StgLet binds body)

        other
390
391
           -> pprPanic "stg2expr" (ppr stgexpr)
     where
392
        doPrimAlt ie (lit,rhs) 
393
           = AltPrim (lit2expr lit) (stg2expr ie rhs)
394
        doAlgAlt ie (dcon,vars,uses,rhs) 
395
           = AltAlg (dataConTag dcon - 1) 
396
397
                    (map id2VaaRep (toHeapOrder vars)) 
			(stg2expr (addListToUniqSet ie vars) rhs)
398
399
400
401
402
403
404

        toHeapOrder vars
           = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
                 (rearranged,offsets)       = unzip rearranged_w_offsets
             in
                 rearranged

405
406
        def2expr ie StgNoDefault         = Nothing
        def2expr ie (StgBindDefault rhs) = Just (stg2expr ie rhs)
407

408
        mkAppChain ie result_rep so_far []
409
           = panic "mkAppChain"
410
411
412
413
        mkAppChain ie result_rep so_far [a]
           = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
        mkAppChain ie result_rep so_far (a:as)
           = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
414
415
416
417

mkCasePrim RepI = CasePrimI
mkCasePrim RepP = CasePrimP

418
419
mkCaseAlg  RepI = CaseAlgI
mkCaseAlg  RepP = CaseAlgP
420

421
422
-- any var that isn't in scope is turned into a Native
mkVar ie rep var
423
424
425
426
427
428
  | var `elementOfUniqSet` ie = 
	(case rep of
	   RepI -> VarI
	   RepF -> VarF
	   RepD -> VarD
	   RepP -> VarP)  var
429
  | otherwise = Native (getName var)
430
431
432
433
434
435
436
437
438

mkRec RepI = RecI
mkRec RepP = RecP
mkNonRec RepI = NonRecI
mkNonRec RepP = NonRecP

mkPrimOp RepI = PrimOpI
mkPrimOp RepP = PrimOpP        

439
440
441
442
arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
arg2expr ie (StgVarArg v)   = mkVar ie (repOfId v) v
arg2expr ie (StgLitArg lit) = lit2expr lit
arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
443
444
445
446
447
448

repOfArg :: StgArg -> Rep
repOfArg (StgVarArg v)   = repOfId v
repOfArg (StgLitArg lit) = repOfLit lit
repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)

449
id2VaaRep var = (var, repOfId var)
450

451

452
-- ---------------------------------------------------------------------------
453
-- Link interpretables into something we can run
454
-- ---------------------------------------------------------------------------
455

456
457
458
459
460
GLOBAL_VAR(cafTable, [], [HValue])

addCAF :: HValue -> IO ()
addCAF x = do xs <- readIORef cafTable; writeIORef cafTable (x:xs)

461
462
linkIModules :: ItblEnv    -- incoming global itbl env; returned updated
	     -> ClosureEnv -- incoming global closure env; returned updated
463
464
	     -> [([UnlinkedIBind], ItblEnv)]
	     -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
465
linkIModules gie gce mods = do
466
  let (bindss, ies) = unzip mods
467
      binds  = concat bindss
468
      top_level_binders = map (getName.binder) binds
469
470
      final_gie = foldr plusFM gie ies
  
471
472
473
474
475
476
477
478
479
  (new_binds, new_gce) <-
    fixIO (\ ~(new_binds, new_gce) -> do

      new_binds <- linkIBinds final_gie new_gce binds

      let new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
      let new_gce = addListToFM gce (zip top_level_binders new_rhss)

      return (new_binds, new_gce))
480

481
  return (new_binds, final_gie, new_gce)
482
483


484
485
486
487
488
-- We're supposed to augment the environments with the values of any
-- external functions/info tables we need as we go along, but that's a
-- lot of hassle so for now I'll look up external things as they crop
-- up and not cache them in the source symbol tables.  The interpreted
-- code will still be referenced in the source symbol tables.
489

490
491
linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> IO [LinkedIBind]
linkIBinds ie ce binds = mapM (linkIBind ie ce) binds
492

493
494
495
linkIBind ie ce (IBind bndr expr)
   = do expr <- linkIExpr ie ce expr
	return (IBind bndr expr)
496

497
linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO LinkedIExpr
498
499
linkIExpr ie ce expr = case expr of

500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
   CaseAlgP  bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgP
   CaseAlgI  bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgI
   CaseAlgF  bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgF
   CaseAlgD  bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgD

   CasePrimP  bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimP
   CasePrimI  bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimI
   CasePrimF  bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimF
   CasePrimD  bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimD

   ConApp con -> lookupNullaryCon ie con

   ConAppI con arg0 -> do
	con' <- lookupCon ie con
	arg' <- linkIExpr ie ce arg0
	return (ConAppI con' arg')

   ConAppP con arg0 -> do
	con' <- lookupCon ie con
	arg' <- linkIExpr ie ce arg0
	return (ConAppP con' arg')

   ConAppPP con arg0 arg1 -> do
	con' <- lookupCon ie con
	arg0' <- linkIExpr ie ce arg0
	arg1' <- linkIExpr ie ce arg1
	return (ConAppPP con' arg0' arg1')

   ConAppGen con args -> do
	con <- lookupCon ie con
	args <- mapM (linkIExpr ie ce) args
	return (ConAppGen con args)
532
   
533
534
   PrimOpI op args -> linkPrimOp ie ce PrimOpI op args
   PrimOpP op args -> linkPrimOp ie ce PrimOpP op args
535
   
536
537
538
539
   NonRecP bind expr  -> linkNonRec ie ce NonRecP bind expr
   NonRecI bind expr  -> linkNonRec ie ce NonRecI bind expr
   NonRecF bind expr  -> linkNonRec ie ce NonRecF bind expr
   NonRecD bind expr  -> linkNonRec ie ce NonRecD bind expr
540

541
542
543
544
   RecP binds expr  -> linkRec ie ce RecP binds expr
   RecI binds expr  -> linkRec ie ce RecI binds expr
   RecF binds expr  -> linkRec ie ce RecF binds expr
   RecD binds expr  -> linkRec ie ce RecD binds expr
545

546
547
548
   LitI i -> return (LitI i)
   LitF i -> return (LitF i)
   LitD i -> return (LitD i)
549
550
551
552
553

   Native var -> lookupNative ce var
   
   VarP v -> lookupVar ce VarP v
   VarI v -> lookupVar ce VarI v
554
555
   VarF v -> lookupVar ce VarF v
   VarD v -> lookupVar ce VarD v
556
   
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
   LamPP  bndr expr -> linkLam ie ce LamPP bndr expr
   LamPI  bndr expr -> linkLam ie ce LamPI bndr expr
   LamPF  bndr expr -> linkLam ie ce LamPF bndr expr
   LamPD  bndr expr -> linkLam ie ce LamPD bndr expr
   LamIP  bndr expr -> linkLam ie ce LamIP bndr expr
   LamII  bndr expr -> linkLam ie ce LamII bndr expr
   LamIF  bndr expr -> linkLam ie ce LamIF bndr expr
   LamID  bndr expr -> linkLam ie ce LamID bndr expr
   LamFP  bndr expr -> linkLam ie ce LamFP bndr expr
   LamFI  bndr expr -> linkLam ie ce LamFI bndr expr
   LamFF  bndr expr -> linkLam ie ce LamFF bndr expr
   LamFD  bndr expr -> linkLam ie ce LamFD bndr expr
   LamDP  bndr expr -> linkLam ie ce LamDP bndr expr
   LamDI  bndr expr -> linkLam ie ce LamDI bndr expr
   LamDF  bndr expr -> linkLam ie ce LamDF bndr expr
   LamDD  bndr expr -> linkLam ie ce LamDD bndr expr
573
   
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
   AppPP  fun arg -> linkApp ie ce AppPP fun arg
   AppPI  fun arg -> linkApp ie ce AppPI fun arg
   AppPF  fun arg -> linkApp ie ce AppPF fun arg
   AppPD  fun arg -> linkApp ie ce AppPD fun arg
   AppIP  fun arg -> linkApp ie ce AppIP fun arg
   AppII  fun arg -> linkApp ie ce AppII fun arg
   AppIF  fun arg -> linkApp ie ce AppIF fun arg
   AppID  fun arg -> linkApp ie ce AppID fun arg
   AppFP  fun arg -> linkApp ie ce AppFP fun arg
   AppFI  fun arg -> linkApp ie ce AppFI fun arg
   AppFF  fun arg -> linkApp ie ce AppFF fun arg
   AppFD  fun arg -> linkApp ie ce AppFD fun arg
   AppDP  fun arg -> linkApp ie ce AppDP fun arg
   AppDI  fun arg -> linkApp ie ce AppDI fun arg
   AppDF  fun arg -> linkApp ie ce AppDF fun arg
   AppDD  fun arg -> linkApp ie ce AppDD fun arg
590
   
591
592
593
594
595
596
597
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
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
linkAlgCase ie ce bndr expr alts dflt con
   = do expr <- linkIExpr ie ce expr
	alts <- mapM (linkAlgAlt ie ce) alts
	dflt <- linkDefault ie ce dflt
	return (con bndr expr alts dflt)

linkPrimCase ie ce bndr expr alts dflt con
   = do expr <- linkIExpr ie ce expr
	alts <- mapM (linkPrimAlt ie ce) alts
	dflt <- linkDefault ie ce dflt
	return (con bndr expr alts dflt)

linkAlgAlt ie ce (AltAlg tag args rhs) 
  = do rhs <- linkIExpr ie ce rhs
       return (AltAlg tag args rhs)

linkPrimAlt ie ce (AltPrim lit rhs) 
  = do rhs <- linkIExpr ie ce rhs
       lit <- linkIExpr ie ce lit
       return (AltPrim lit rhs)

linkDefault ie ce Nothing = return Nothing
linkDefault ie ce (Just expr) 
   = do expr <- linkIExpr ie ce expr
	return (Just expr)

linkNonRec ie ce con bind expr 
   = do expr <- linkIExpr ie ce expr
	bind <- linkIBind ie ce bind
        return (con bind expr)

linkRec ie ce con binds expr 
   = do expr <- linkIExpr ie ce expr
	binds <- linkIBinds ie ce binds
        return (con binds expr)

linkLam ie ce con bndr expr
   = do expr <- linkIExpr ie ce expr
        return (con bndr expr)

linkApp ie ce con fun arg
   = do fun <- linkIExpr ie ce fun
        arg <- linkIExpr ie ce arg
	return (con fun arg)

linkPrimOp ie ce con op args
   = do args <- mapM (linkIExpr ie ce) args
	return (con op args)

640
641
lookupCon ie con = 
  case lookupFM ie con of
642
643
    Just (Ptr addr) -> return addr
    Nothing   -> do
644
	-- try looking up in the object files.
645
        m <- lookupSymbol (nameToCLabel con "con_info")
646
647
648
	case m of
	    Just addr -> return addr
  	    Nothing   -> pprPanic "linkIExpr" (ppr con)
649

650
651
652
-- nullary constructors don't have normal _con_info tables.
lookupNullaryCon ie con =
  case lookupFM ie con of
653
654
    Just (Ptr addr) -> return (ConApp addr)
    Nothing -> do
655
	-- try looking up in the object files.
656
	m <- lookupSymbol (nameToCLabel con "closure")
657
658
	case m of
	    Just (A# addr) -> return (Native (unsafeCoerce# addr))
659
660
661
	    Nothing   -> pprPanic "lookupNullaryCon" (ppr con)


662
lookupNative ce var =
663
664
665
666
667
  unsafeInterleaveIO (do
      case lookupFM ce var of
    	Just e  -> return (Native e)
    	Nothing -> do
    	    -- try looking up in the object files.
668
    	    let lbl = (nameToCLabel var "closure")
669
670
    	    m <- lookupSymbol lbl
    	    case m of
671
672
673
    		Just (A# addr)
		    -> do addCAF (unsafeCoerce# addr)
			  return (Native (unsafeCoerce# addr))
674
675
    		Nothing   -> pprPanic "linkIExpr" (ppr var)
  )
676
677
678
679

-- some VarI/VarP refer to top-level interpreted functions; we change
-- them into Natives here.
lookupVar ce f v =
680
681
682
683
  unsafeInterleaveIO (
	case lookupFM ce (getName v) of
	    Nothing -> return (f v)
	    Just e  -> return (Native e)
684
  )
685
686

-- HACK!!!  ToDo: cleaner
687
688
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix =
689
690
  _UNPK_(moduleNameFS (rdrNameModule rn)) 
  ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
691
  where rn = toRdrName n
692
693
694
695

-- ---------------------------------------------------------------------------
-- The interpreter proper
-- ---------------------------------------------------------------------------
696
697
698
699
700
701

-- The dynamic environment contains everything boxed.
-- eval* functions which look up values in it will know the
-- representation of the thing they are looking up, so they
-- can cast/unbox it as necessary.

702
703
704
-- ---------------------------------------------------------------------------
-- Evaluator for things of boxed (pointer) representation
-- ---------------------------------------------------------------------------
705

706
707
708
interp :: LinkedIExpr -> HValue
interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)

709
evalP :: LinkedIExpr -> UniqFM boxed -> boxed
710

711
{-
712
evalP expr de
713
--   | trace ("evalP: " ++ showExprTag expr) False
714
   | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
715
   = error "evalP: ?!?!"
716
-}
717

718
evalP (Native p) de  = unsafeCoerce# p
719
720
721
722
723
724

-- First try the dynamic env.  If that fails, assume it's a top-level
-- binding and look in the static env.  That gives an Expr, which we
-- must convert to a boxed thingy by applying evalP to it.  Because
-- top-level bindings are always ptr-rep'd (either lambdas or boxed
-- CAFs), it's always safe to use evalP.
725
726
evalP (VarP v) de 
   = case lookupUFM de v of
727
        Just xx -> xx
728
        Nothing -> error ("evalP: lookupUFM " ++ show v)
729
730
731
732

-- Deal with application of a function returning a pointer rep
-- to arguments of any persuasion.  Note that the function itself
-- always has pointer rep.
733
734
evalP (AppIP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalP (AppPP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalP e2 de)
735
736
evalP (AppFP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalF e2 de)
evalP (AppDP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalD e2 de)
737
738
739

-- Lambdas always return P-rep, but we need to do different things
-- depending on both the argument and result representations.
740
evalP (LamPP x b) de
741
   = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
742
evalP (LamPI x b) de
743
744
745
746
747
   = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
evalP (LamPF x b) de
   = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
evalP (LamPD x b) de
   = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
748
evalP (LamIP x b) de
749
   = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
750
evalP (LamII x b) de
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
   = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
evalP (LamIF x b) de
   = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
evalP (LamID x b) de
   = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
evalP (LamFP x b) de
   = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
evalP (LamFI x b) de
   = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
evalP (LamFF x b) de
   = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
evalP (LamFD x b) de
   = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
evalP (LamDP x b) de
   = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
evalP (LamDI x b) de
   = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
evalP (LamDF x b) de
   = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
evalP (LamDD x b) de
   = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
772
773
774
775
776


-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, 
-- except in the sense that we go on and evaluate the body with whichever
-- evaluator was used for the expression as a whole.
777
778
779
780
781
782
783
784
785
786
evalP (NonRecP bind e) de
   = evalP e (augment_nonrec bind de)
evalP (RecP binds b) de
   = evalP b (augment_rec binds de)
evalP (CaseAlgP bndr expr alts def) de
   = case helper_caseAlg bndr expr alts def de of
        (rhs, de') -> evalP rhs de'
evalP (CasePrimP bndr expr alts def) de
   = case helper_casePrim bndr expr alts def de of
        (rhs, de') -> evalP rhs de'
787

788
789
evalP (ConApp (A# itbl)) de
   = mci_make_constr0 itbl
790

791
792
evalP (ConAppI (A# itbl) a1) de
   = case evalI a1 de of i1 -> mci_make_constrI itbl i1
793

794
evalP (ConAppP (A# itbl) a1) de
795
796
797
   = evalP (ConAppGen (A# itbl) [a1]) de
--   = let p1 = evalP a1 de
--     in  mci_make_constrP itbl p1
798

799
800
801
evalP (ConAppPP (A# itbl) a1 a2) de
   = let p1 = evalP a1 de
         p2 = evalP a2 de
802
803
     in  mci_make_constrPP itbl p1 p2

804
evalP (ConAppGen itbl args) de
805
806
   = let c = case itbl of A# a# -> mci_make_constr a# in
     c `seq` loop c 1#{-leave room for hdr-} args
807
     where
808
809
810
        loop :: a{-closure-} -> Int# -> [LinkedIExpr] -> a
        loop c off [] = c
        loop c off (a:as)
811
           = case repOf a of
812
813
814
815
816
817
818
819
820
821
822
                RepP -> let c' = setPtrOffClosure c off (evalP a de)
			in c' `seq` loop c' (off +# 1#) as
                RepI -> case evalI a de of { i# -> 
			let c' = setIntOffClosure c off i#
			in c' `seq` loop c' (off +# 1#) as }
	        RepF -> case evalF a de of { f# -> 
			let c' = setFloatOffClosure c off f# 
			in c' `seq` loop c' (off +# 1#) as }
	        RepD -> case evalD a de of { d# -> 
			let c' = setDoubleOffClosure c off d#
			in c' `seq` loop c' (off +# 2#) as }
823

824
825
826
827
evalP (PrimOpP IntEqOp [e1,e2]) de 
    = case evalI e1 de of 
         i1# -> case evalI e2 de of 
                   i2# -> unsafeCoerce# (i1# ==# i2#)
828
829
830

evalP (PrimOpP primop _) de
   = error ("evalP: unhandled primop: " ++ showSDoc (ppr primop))
831
evalP other de
832
833
834
835
836
837
838
   = error ("evalP: unhandled case: " ++ showExprTag other)

--------------------------------------------------------
--- Evaluator for things of Int# representation
--------------------------------------------------------

-- Evaluate something which has an unboxed Int rep
839
evalI :: LinkedIExpr -> UniqFM boxed -> Int#
840

841
{-
842
evalI expr de
843
--   | trace ("evalI: " ++ showExprTag expr) False
844
845
   | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
   = error "evalI: ?!?!"
846
-}
847
848
849
850
851
852
853

evalI (LitI i#) de = i#

evalI (VarI v) de = 
   case lookupUFM de v of
	Just e  -> case unsafeCoerce# e of I# i -> i
	Nothing -> error ("evalI: lookupUFM " ++ show v)
854
855
856
857

-- Deal with application of a function returning an Int# rep
-- to arguments of any persuasion.  Note that the function itself
-- always has pointer rep.
858
859
860
861
evalI (AppII e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalI (AppPI e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalP e2 de)
862
863
864
865
evalI (AppFI e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalF e2 de)
evalI (AppDI e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalD e2 de)
866
867
868
869

-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, 
-- except in the sense that we go on and evaluate the body with whichever
-- evaluator was used for the expression as a whole.
870
871
872
873
874
875
876
877
878
879
evalI (NonRecI bind b) de
   = evalI b (augment_nonrec bind de)
evalI (RecI binds b) de
   = evalI b (augment_rec binds de)
evalI (CaseAlgI bndr expr alts def) de
   = case helper_caseAlg bndr expr alts def de of
        (rhs, de') -> evalI rhs de'
evalI (CasePrimI bndr expr alts def) de
   = case helper_casePrim bndr expr alts def de of
        (rhs, de') -> evalI rhs de'
880
881
882
883

-- evalI can't be applied to a lambda term, by defn, since those
-- are ptr-rep'd.

884
885
evalI (PrimOpI IntAddOp [e1,e2]) de  = evalI e1 de +# evalI e2 de
evalI (PrimOpI IntSubOp [e1,e2]) de  = evalI e1 de -# evalI e2 de
886
887
888
889
evalI (PrimOpI DataToTagOp [e1]) de  = dataToTag# (evalP e1 de)

evalI (PrimOpI primop _) de
   = error ("evalI: unhandled primop: " ++ showSDoc (ppr primop))
890

891
892
--evalI (NonRec (IBind v e) b) de
--   = evalI b (augment de v (eval e de))
893

894
evalI other de
895
896
   = error ("evalI: unhandled case: " ++ showExprTag other)

897
898
899
900
901
902
903
--------------------------------------------------------
--- Evaluator for things of Float# representation
--------------------------------------------------------

-- Evaluate something which has an unboxed Int rep
evalF :: LinkedIExpr -> UniqFM boxed -> Float#

904
{-
905
906
907
908
evalF expr de
--   | trace ("evalF: " ++ showExprTag expr) False
   | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
   = error "evalF: ?!?!"
909
-}
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959

evalF (LitF f#) de = f#

evalF (VarF v) de = 
   case lookupUFM de v of
	Just e  -> case unsafeCoerce# e of F# i -> i
	Nothing -> error ("evalF: lookupUFM " ++ show v)

-- Deal with application of a function returning an Int# rep
-- to arguments of any persuasion.  Note that the function itself
-- always has pointer rep.
evalF (AppIF e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalF (AppPF e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalP e2 de)
evalF (AppFF e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalF e2 de)
evalF (AppDF e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalD e2 de)

-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, 
-- except in the sense that we go on and evaluate the body with whichever
-- evaluator was used for the expression as a whole.
evalF (NonRecF bind b) de
   = evalF b (augment_nonrec bind de)
evalF (RecF binds b) de
   = evalF b (augment_rec binds de)
evalF (CaseAlgF bndr expr alts def) de
   = case helper_caseAlg bndr expr alts def de of
        (rhs, de') -> evalF rhs de'
evalF (CasePrimF bndr expr alts def) de
   = case helper_casePrim bndr expr alts def de of
        (rhs, de') -> evalF rhs de'

-- evalF can't be applied to a lambda term, by defn, since those
-- are ptr-rep'd.

evalF (PrimOpF op _) de 
  = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))

evalF other de
  = error ("evalF: unhandled case: " ++ showExprTag other)

--------------------------------------------------------
--- Evaluator for things of Double# representation
--------------------------------------------------------

-- Evaluate something which has an unboxed Int rep
evalD :: LinkedIExpr -> UniqFM boxed -> Double#

960
{-
961
962
963
964
evalD expr de
--   | trace ("evalD: " ++ showExprTag expr) False
   | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
   = error "evalD: ?!?!"
965
-}
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008

evalD (LitD d#) de = d#

evalD (VarD v) de = 
   case lookupUFM de v of
	Just e  -> case unsafeCoerce# e of D# i -> i
	Nothing -> error ("evalD: lookupUFM " ++ show v)

-- Deal with application of a function returning an Int# rep
-- to arguments of any persuasion.  Note that the function itself
-- always has pointer rep.
evalD (AppID e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalD (AppPD e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalP e2 de)
evalD (AppFD e1 e2) de 
   = unsafeCoerce# (evalP e1 de) (evalF e2 de)
evalD (AppDD e1 e2) de
   = unsafeCoerce# (evalP e1 de) (evalD e2 de)

-- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, 
-- except in the sense that we go on and evaluate the body with whichever
-- evaluator was used for the expression as a whole.
evalD (NonRecD bind b) de
   = evalD b (augment_nonrec bind de)
evalD (RecD binds b) de
   = evalD b (augment_rec binds de)
evalD (CaseAlgD bndr expr alts def) de
   = case helper_caseAlg bndr expr alts def de of
        (rhs, de') -> evalD rhs de'
evalD (CasePrimD bndr expr alts def) de
   = case helper_casePrim bndr expr alts def de of
        (rhs, de') -> evalD rhs de'

-- evalD can't be applied to a lambda term, by defn, since those
-- are ptr-rep'd.

evalD (PrimOpD op _) de
  = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))

evalD other de 
  = error ("evalD: unhandled case: " ++ showExprTag other)

1009
1010
1011
1012
1013
--------------------------------------------------------
--- Helper bits and pieces
--------------------------------------------------------

-- Find the Rep of any Expr
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
repOf :: LinkedIExpr -> Rep

repOf (LamPP _ _)      = RepP 
repOf (LamPI _ _)      = RepP 
repOf (LamPF _ _)      = RepP 
repOf (LamPD _ _)      = RepP 
repOf (LamIP _ _)      = RepP 
repOf (LamII _ _)      = RepP 
repOf (LamIF _ _)      = RepP 
repOf (LamID _ _)      = RepP 
repOf (LamFP _ _)      = RepP 
repOf (LamFI _ _)      = RepP 
repOf (LamFF _ _)      = RepP 
repOf (LamFD _ _)      = RepP 
repOf (LamDP _ _)      = RepP 
repOf (LamDI _ _)      = RepP 
repOf (LamDF _ _)      = RepP 
repOf (LamDD _ _)      = RepP 
1032

1033
repOf (AppPP _ _)      = RepP
1034
1035
1036
repOf (AppPI _ _)      = RepI
repOf (AppPF _ _)      = RepF
repOf (AppPD _ _)      = RepD
1037
repOf (AppIP _ _)      = RepP
1038
1039
1040
repOf (AppII _ _)      = RepI
repOf (AppIF _ _)      = RepF
repOf (AppID _ _)      = RepD
1041
repOf (AppFP _ _)      = RepP
1042
1043
1044
repOf (AppFI _ _)      = RepI
repOf (AppFF _ _)      = RepF
repOf (AppFD _ _)      = RepD
1045
repOf (AppDP _ _)      = RepP
1046
1047
1048
repOf (AppDI _ _)      = RepI
repOf (AppDF _ _)      = RepF
repOf (AppDD _ _)      = RepD
1049
1050

repOf (NonRecP _ _)    = RepP
1051
repOf (NonRecI _ _)    = RepI
1052
1053
repOf (NonRecF _ _)    = RepF
repOf (NonRecD _ _)    = RepD
1054

1055
1056
1057
1058
1059
repOf (RecP _ _)       = RepP
repOf (RecI _ _)       = RepI
repOf (RecF _ _)       = RepF
repOf (RecD _ _)       = RepD

1060
repOf (LitI _)         = RepI
1061
1062
repOf (LitF _)         = RepF
repOf (LitD _)         = RepD
1063

1064
1065
repOf (Native _)       = RepP

1066
repOf (VarP _)         = RepP
1067
1068
1069
repOf (VarI _)         = RepI
repOf (VarF _)         = RepF
repOf (VarD _)         = RepD
1070
1071

repOf (PrimOpP _ _)    = RepP
1072
1073
1074
repOf (PrimOpI _ _)    = RepI
repOf (PrimOpF _ _)    = RepF
repOf (PrimOpD _ _)    = RepD
1075

1076
1077
1078
1079
repOf (ConApp _)       = RepP
repOf (ConAppI _ _)    = RepP
repOf (ConAppP _ _)    = RepP
repOf (ConAppPP _ _ _) = RepP
1080
repOf (ConAppGen _ _)  = RepP
1081
1082

repOf (CaseAlgP _ _ _ _) = RepP
1083
1084
1085
1086
1087
1088
1089
1090
repOf (CaseAlgI _ _ _ _) = RepI
repOf (CaseAlgF _ _ _ _) = RepF
repOf (CaseAlgD _ _ _ _) = RepD

repOf (CasePrimP _ _ _ _) = RepP
repOf (CasePrimI _ _ _ _) = RepI
repOf (CasePrimF _ _ _ _) = RepF
repOf (CasePrimD _ _ _ _) = RepD
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105

repOf other         
   = error ("repOf: unhandled case: " ++ showExprTag other)

-- how big (in words) is one of these
repSizeW :: Rep -> Int
repSizeW RepI = 1
repSizeW RepP = 1


-- Evaluate an expression, using the appropriate evaluator,
-- then box up the result.  Note that it's only safe to use this 
-- to create values to put in the environment.  You can't use it 
-- to create a value which might get passed to native code since that
-- code will have no idea that unboxed things have been boxed.
1106
1107
eval :: LinkedIExpr -> UniqFM boxed -> boxed
eval expr de
1108
   = case repOf expr of
1109
1110
        RepI -> unsafeCoerce# (I# (evalI expr de))
        RepP -> evalP expr de
1111
1112
        RepF -> unsafeCoerce# (F# (evalF expr de))
        RepD -> unsafeCoerce# (D# (evalD expr de))
1113
1114
1115
1116

-- Evaluate the scrutinee of a case, select an alternative,
-- augment the environment appropriately, and return the alt
-- and the augmented environment.
1117
1118
1119
1120
1121
helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr 
                  -> UniqFM boxed
                  -> (LinkedIExpr, UniqFM boxed)
helper_caseAlg bndr expr alts def de
   = let exprEv = evalP expr de
1122
1123
1124
     in  
     exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
     case select_altAlg (tagOf exprEv) alts def of
1125
        (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv) 
1126
1127
                                                exprEv (vars,1))

1128
1129
1130
1131
helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr 
                   -> UniqFM boxed
                   -> (LinkedIExpr, UniqFM boxed)
helper_casePrim bndr expr alts def de
1132
   = case repOf expr of
1133
        RepI -> case evalI expr de of 
1134
                   i# -> (select_altPrim alts def (LitI i#), 
1135
                          addToUFM de bndr (unsafeCoerce# (I# i#)))
1136
1137
1138
1139
1140
1141
        RepF -> case evalF expr de of 
                   f# -> (select_altPrim alts def (LitF f#), 
                          addToUFM de bndr (unsafeCoerce# (F# f#)))
        RepD -> case evalD expr de of 
                   d# -> (select_altPrim alts def (LitD d#), 
                          addToUFM de bndr (unsafeCoerce# (D# d#)))
1142
1143


1144
augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1145
1146
augment_from_constr de con ([],offset) 
   = de
1147
augment_from_constr de con ((v,rep):vs,offset)
1148
   = let v_binding
1149
            = case rep of
1150
1151
                 RepP -> indexPtrOffClosure con offset
                 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1152
1153
                 RepF -> unsafeCoerce# (F# (indexFloatOffClosure con offset))
                 RepD -> unsafeCoerce# (D# (indexDoubleOffClosure con offset))
1154
     in
1155
1156
         augment_from_constr (addToUFM de v v_binding) con 
                             (vs,offset + repSizeW rep)
1157
1158

-- Augment the environment for a non-recursive let.
1159
1160
augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
augment_nonrec (IBind v e) de  = addToUFM de v (eval e de)
1161
1162

-- Augment the environment for a recursive let.
1163
1164
augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
augment_rec binds de
1165
1166
   = let vars   = map binder binds
         rhss   = map bindee binds
1167
1168
         rhs_vs = map (\rhs -> eval rhs de') rhss
         de'    = addListToUFM de (zip vars rhs_vs)
1169
1170
1171
1172
1173
1174
1175
     in
         de'

-- a must be a constructor?
tagOf :: a -> Int
tagOf x = I# (dataToTag# x)

1176
select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1177
1178
1179
1180
1181
1182
1183
1184
select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
select_altAlg tag [] (Just def) = ([],def)
select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
   = if   tag == tagNo 
     then (vars,rhs) 
     else select_altAlg tag alts def

-- literal may only be a literal, not an arbitrary expression
1185
select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1186
1187
1188
1189
1190
1191
1192
1193
1194
select_altPrim [] Nothing    literal = error "select_altPrim: no match and no default?!"
select_altPrim [] (Just def) literal = def
select_altPrim ((AltPrim lit rhs):alts) def literal
   = if eqLits lit literal
     then rhs
     else select_altPrim alts def literal

eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#

1195
1196
1197
-- ----------------------------------------------------------------------
-- Grotty inspection and creation of closures
-- ----------------------------------------------------------------------
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207

-- a is a constructor
indexPtrOffClosure :: a -> Int -> b
indexPtrOffClosure con (I# offset)
   = case indexPtrOffClosure# con offset of (# x #) -> x

indexIntOffClosure :: a -> Int -> Int#
indexIntOffClosure con (I# offset)
   = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#

1208
1209
indexFloatOffClosure :: a -> Int -> Float#
indexFloatOffClosure con (I# offset)
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
   = unsafeCoerce# (indexWordOffClosure# con offset) 
	-- TOCK TOCK TOCK! Those GHC developers are crazy.

indexDoubleOffClosure :: a -> Int -> Double#
indexDoubleOffClosure con (I# offset)
   = unsafeCoerce# (panic "indexDoubleOffClosure")

setPtrOffClosure :: a -> Int# -> b -> a
setPtrOffClosure a i b = case setPtrOffClosure# a i b of (# c #) -> c

setIntOffClosure :: a -> Int# -> Int# -> a
setIntOffClosure a i b = case setWordOffClosure# a i (int2Word# b) of (# c #) -> c

setFloatOffClosure :: a -> Int# -> Float# -> a
setFloatOffClosure a i b = case setWordOffClosure# a i (unsafeCoerce# b) of (# c #) -> c

setDoubleOffClosure :: a -> Int# -> Double# -> a
setDoubleOffClosure a i b = unsafeCoerce# (panic "setDoubleOffClosure")
1228
1229
1230
1231
1232

------------------------------------------------------------------------
--- Manufacturing of info tables for DataCons defined in this module ---
------------------------------------------------------------------------

1233
1234
1235
1236
1237
1238
#if __GLASGOW_HASKELL__ <= 408
type ItblPtr = Addr
#else
type ItblPtr = Ptr StgInfoTable
#endif

1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
mkITbls [] = return emptyFM
mkITbls (tc:tcs) = do itbls  <- mkITbl tc
                      itbls2 <- mkITbls tcs
                      return (itbls `plusFM` itbls2)

mkITbl :: TyCon -> IO ItblEnv
mkITbl tc
--   | trace ("TYCON: " ++ showSDoc (ppr tc)) False
--   = error "?!?!"
   | not (isDataTyCon tc) 
   = return emptyFM
   | n == length dcs  -- paranoia; this is an assertion.
   = make_constr_itbls dcs
     where
        dcs = tyConDataCons tc
        n   = tyConFamilySize tc

1258
1259
1260
1261
1262
1263
1264
cONSTR :: Int
cONSTR = 1  -- as defined in ghc/includes/ClosureTypes.h

-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
   | length cons <= 8
1265
1266
   = do is <- mapM mk_vecret_itbl (zip cons [0..])
	return (listToFM is)
1267
   | otherwise
1268
1269
   = do is <- mapM mk_dirret_itbl (zip cons [0..])
	return (listToFM is)
1270
1271
1272
1273
1274
1275
     where
        mk_vecret_itbl (dcon, conNo)
           = mk_itbl dcon conNo (vecret_entry conNo)
        mk_dirret_itbl (dcon, conNo)
           = mk_itbl dcon conNo mci_constr_entry

1276
        mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
        mk_itbl dcon conNo entry_addr
           = let (tot_wds, ptr_wds, _) 
                    = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
                 ptrs = ptr_wds
                 nptrs  = tot_wds - ptr_wds
                 itbl  = StgInfoTable {
                           ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
                           tipe = fromIntegral cONSTR,
                           srtlen = fromIntegral conNo,
                           code0 = fromIntegral code0, code1 = fromIntegral code1,
                           code2 = fromIntegral code2, code3 = fromIntegral code3,
                           code4 = fromIntegral code4, code5 = fromIntegral code5,
                           code6 = fromIntegral code6, code7 = fromIntegral code7 
                        }
                 -- Make a piece of code to jump to "entry_label".
                 -- This is the only arch-dependent bit.
                 -- On x86, if entry_label has an address 0xWWXXYYZZ,
                 -- emit   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
                 -- which is
                 -- B8 ZZ YY XX WW FF E0
                 (code0,code1,code2,code3,code4,code5,code6,code7)
                    = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w, 
                             byte 2 entry_addr_w, byte 3 entry_addr_w, 
                       0xFF, 0xE0, 
                       0x90 {-nop-})

                 entry_addr_w :: Word32
                 entry_addr_w = fromIntegral (addrToInt entry_addr)
             in
1306
                 do addr <- malloc
1307
1308
1309
                    --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
                    --putStrLn ("# ptrs  of itbl is " ++ show ptrs)
                    --putStrLn ("# nptrs of itbl is " ++ show nptrs)
1310
                    poke addr itbl
1311
                    return (getName dcon, addr `plusPtr` 8)
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330


byte :: Int -> Word32 -> Word32
byte 0 w = w .&. 0xFF
byte 1 w = (w `shiftR` 8) .&. 0xFF
byte 2 w = (w `shiftR` 16) .&. 0xFF
byte 3 w = (w `shiftR` 24) .&. 0xFF


vecret_entry 0 = mci_constr1_entry
vecret_entry 1 = mci_constr2_entry
vecret_entry 2 = mci_constr3_entry
vecret_entry 3 = mci_constr4_entry
vecret_entry 4 = mci_constr5_entry
vecret_entry 5 = mci_constr6_entry
vecret_entry 6 = mci_constr7_entry
vecret_entry 7 = mci_constr8_entry

-- entry point for direct returns for created constr itbls
1331
foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1332
-- and the 8 vectored ones
1333
1334
1335
1336
1337
1338
1339
1340
foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371



data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}


-- Ultra-minimalist version specially for constructors
data StgInfoTable = StgInfoTable {
   ptrs :: Word16,
   nptrs :: Word16,
   srtlen :: Word16,
   tipe :: Word16,
   code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
}


instance Storable StgInfoTable where

   sizeOf itbl 
      = (sum . map (\f -> f itbl))
        [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
         fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3, 
         fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]

   alignment itbl 
      = (sum . map (\f -> f itbl))
        [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
         fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3, 
         fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]

   poke a0 itbl
1372
      = do a1 <- store (ptrs   itbl) (castPtr a0)
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
           a2 <- store (nptrs  itbl) a1
           a3 <- store (tipe   itbl) a2
           a4 <- store (srtlen itbl) a3
           a5 <- store (code0  itbl) a4
           a6 <- store (code1  itbl) a5
           a7 <- store (code2  itbl) a6
           a8 <- store (code3  itbl) a7
           a9 <- store (code4  itbl) a8
           aA <- store (code5  itbl) a9
           aB <- store (code6  itbl) aA
           aC <- store (code7  itbl) aB
           return ()

   peek a0
1387
      = do (a1,ptrs)   <- load (castPtr a0)
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
           (a2,nptrs)  <- load a1
           (a3,tipe)   <- load a2
           (a4,srtlen) <- load a3
           (a5,code0)  <- load a4
           (a6,code1)  <- load a5
           (a7,code2)  <- load a6
           (a8,code3)  <- load a7
           (a9,code4)  <- load a8
           (aA,code5)  <- load a9
           (aB,code6)  <- load aA
           (aC,code7)  <- load aB
           return StgInfoTable { ptrs = ptrs, nptrs = nptrs, 
                                 srtlen = srtlen, tipe = tipe,
                                 code0 = code0, code1 = code1, code2 = code2,
                                 code3 = code3, code4 = code4, code5 = code5,
                                 code6 = code6, code7 = code7 }

fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldSz sel x = sizeOf (sel x)

fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldAl sel x = alignment (sel x)

1411
store :: Storable a => a -> Ptr a -> IO (Ptr b)
1412
store x addr = do poke addr x
1413
                  return (castPtr (addr `plusPtr` sizeOf x))
1414

1415
load :: Storable a => Ptr a -> IO (Ptr b, a)
1416
load addr = do x <- peek addr
1417
               return (castPtr (addr `plusPtr` sizeOf x), x)
1418

1419
-----------------------------------------------------------------------------q
1420

1421
foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1422
1423
#endif

1424
1425
\end{code}