2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
12 -- runStgI -- tmp, for testing
15 {- -----------------------------------------------------------------------------
18 - link should be in the IO monad, so it can modify the symtabs as it
21 - need a way to remove the bindings for a module from the symtabs.
22 maybe the symtabs should be indexed by module first.
24 - change the representation to something less verbose (?).
26 - converting string literals to Addr# is horrible and introduces
27 a memory leak. See if something can be done about this.
29 ----------------------------------------------------------------------------- -}
31 #include "HsVersions.h"
35 import Id ( Id, idPrimRep )
38 import PrimOp ( PrimOp(..) )
39 import PrimRep ( PrimRep(..) )
40 import Literal ( Literal(..) )
41 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
42 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
43 import ClosureInfo ( mkVirtHeapOffsets )
44 import Name ( toRdrName )
48 import {-# SOURCE #-} MCI_make_constr
50 import IOExts ( unsafePerformIO ) -- ToDo: remove
51 import PrelGHC --( unsafeCoerce#, dataToTag#,
52 -- indexPtrOffClosure#, indexWordOffClosure# )
53 import IO ( hPutStr, stderr )
55 import PrelAddr ( Addr(..) )
56 import PrelFloat ( Float(..), Double(..) )
62 import GlaExts ( Int(..) )
63 import Module ( moduleNameFS )
66 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
67 import Class ( Class, classTyCon )
71 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
73 import Panic ( panic )
74 import OccName ( occNameString )
77 -- ---------------------------------------------------------------------------
78 -- Environments needed by the linker
79 -- ---------------------------------------------------------------------------
81 type ItblEnv = FiniteMap RdrName Addr
82 type ClosureEnv = FiniteMap RdrName HValue
84 -- ---------------------------------------------------------------------------
85 -- Run our STG program through the interpreter
86 -- ---------------------------------------------------------------------------
89 -- To be nuked at some point soon.
90 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
92 -- the bindings need to have a binding for stgMain, and the
93 -- body of it had better represent something of type Int# -> Int#
94 runStgI tycons classes stgbinds
96 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
100 = "-------------------- Unlinked Binds --------------------\n"
101 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
104 hPutStr stderr dbg_txt
106 (linked_binds, ie, ce) <-
107 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
110 = "-------------------- Linked Binds --------------------\n"
111 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
114 hPutStr stderr dbg_txt
117 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
119 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
122 = I# (evalI (AppII stgMain (LitI 0#))
123 emptyUFM{-initial de-}
128 -- ---------------------------------------------------------------------------
129 -- Convert STG to an unlinked interpretable
130 -- ---------------------------------------------------------------------------
132 -- visible from outside
133 stgToInterpSyn :: [StgBinding]
134 -> [TyCon] -> [Class]
135 -> IO ([UnlinkedIBind], ItblEnv)
136 stgToInterpSyn binds local_tycons local_classes
137 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
138 let tycs = local_tycons ++ map classTyCon local_classes
139 itblenv <- mkITbls tycs
140 return (ibinds, itblenv)
143 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
144 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
145 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
146 where ie' = addListToUniqSet ie (map fst vs_n_es)
148 isRec (StgNonRec _ _) = False
149 isRec (StgRec _) = True
151 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
152 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
155 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
156 rhsRep = repOfStgExpr rhs
157 mkLambdas [] = rhsExpr
158 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
159 rhs2expr ie (StgRhsCon ccs dcon args)
160 = conapp2expr ie dcon args
162 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
163 conapp2expr ie dcon args
164 = mkConApp con_rdrname reps exprs
166 con_rdrname = toRdrName dcon
167 exprs = map (arg2expr ie) inHeapOrder
168 reps = map repOfArg inHeapOrder
169 inHeapOrder = toHeapOrder args
171 toHeapOrder :: [StgArg] -> [StgArg]
173 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
174 (rearranged, offsets) = unzip rearranged_w_offsets
178 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
180 -- Handle most common cases specially; do the rest with a generic
181 -- mechanism (deferred till later :)
182 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
183 mkConApp nm [] [] = ConApp nm
184 mkConApp nm [RepI] [a1] = ConAppI nm a1
185 mkConApp nm [RepP] [a1] = ConAppP nm a1
186 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
187 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
188 mkConApp nm reps args
189 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
191 mkLam RepP RepP = LamPP
192 mkLam RepI RepP = LamIP
193 mkLam RepP RepI = LamPI
194 mkLam RepI RepI = LamII
195 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
197 mkApp RepP RepP = AppPP
198 mkApp RepI RepP = AppIP
199 mkApp RepP RepI = AppPI
200 mkApp RepI RepI = AppII
201 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
204 repOfId = primRep2Rep . idPrimRep
209 -- genuine lifted types
212 -- all these are unboxed, fit into a word, and we assume they
213 -- all have the same call/return convention.
221 -- these are pretty dodgy: really pointers, but
222 -- we can't let the compiler build thunks with these reps.
223 ForeignObjRep -> RepP
224 StableNameRep -> RepP
229 other -> pprPanic "primRep2Rep" (ppr other)
231 repOfStgExpr :: StgExpr -> Rep
236 StgCase scrut live liveR bndr srt alts
237 -> case altRhss alts of
238 (a:_) -> repOfStgExpr a
239 [] -> panic "repOfStgExpr: no alts"
243 -> repOfApp ((deNoteType.repType.idType) var) (length args)
245 StgPrimApp op args res_ty
246 -> (primRep2Rep.typePrimRep) res_ty
248 StgLet binds body -> repOfStgExpr body
249 StgLetNoEscape live liveR binds body -> repOfStgExpr body
251 StgConApp con args -> RepP -- by definition
254 -> pprPanic "repOfStgExpr" (ppr other)
256 altRhss (StgAlgAlts ty alts def)
257 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
258 altRhss (StgPrimAlts ty alts def)
259 = [rhs | (lit,rhs) <- alts] ++ defRhs def
262 defRhs (StgBindDefault rhs)
265 -- returns the Rep of the result of applying ty to n args.
266 repOfApp :: Type -> Int -> Rep
267 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
268 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
280 MachStr _ -> RepI -- because it's a ptr outside the heap
281 other -> pprPanic "repOfLit" (ppr lit)
283 lit2expr :: Literal -> UnlinkedIExpr
286 MachInt i -> case fromIntegral i of I# i -> LitI i
287 MachWord i -> case fromIntegral i of I# i -> LitI i
288 MachAddr i -> case fromIntegral i of I# i -> LitI i
289 MachChar i -> case fromIntegral i of I# i -> LitI i
290 MachFloat f -> case fromRational f of F# f -> LitF f
291 MachDouble f -> case fromRational f of D# f -> LitD f
294 CharStr s i -> LitI (addr2Int# s)
297 -- sigh, a string in the heap is no good to us. We need a
298 -- static C pointer, since the type of a string literal is
299 -- Addr#. So, copy the string into C land and introduce a
300 -- memory leak at the same time.
302 case unsafePerformIO (do a <- malloc (n+1);
303 strncpy a ba (fromIntegral n);
304 writeCharOffAddr a n '\0'
306 of A# a -> LitI (addr2Int# a)
308 _ -> error "StgInterp.lit2expr: unhandled string constant type"
310 other -> pprPanic "lit2expr" (ppr lit)
312 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
316 -> mkVar ie (repOfId var) var
319 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
323 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
324 | repOfStgExpr scrut /= RepP
325 -> mkCasePrim (repOfStgExpr stgexpr)
326 bndr (stg2expr ie scrut)
330 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
331 | repOfStgExpr scrut == RepP
332 -> mkCaseAlg (repOfStgExpr stgexpr)
333 bndr (stg2expr ie scrut)
337 StgPrimApp op args res_ty
338 -> mkPrimOp (repOfStgExpr stgexpr)
339 op (map (arg2expr ie) args)
342 -> conapp2expr ie dcon args
344 StgLet binds@(StgNonRec v e) body
345 -> mkNonRec (repOfStgExpr stgexpr)
346 (head (translateBind ie binds))
347 (stg2expr (addOneToUniqSet ie v) body)
349 StgLet binds@(StgRec bs) body
350 -> mkRec (repOfStgExpr stgexpr)
351 (translateBind ie binds)
352 (stg2expr (addListToUniqSet ie (map fst bs)) body)
355 -> pprPanic "stg2expr" (ppr stgexpr)
358 = AltPrim (lit2expr lit) (stg2expr ie rhs)
359 doAlgAlt (dcon,vars,uses,rhs)
360 = AltAlg (dataConTag dcon - 1)
361 (map id2VaaRep (toHeapOrder vars))
362 (stg2expr (addListToUniqSet ie vars) rhs)
365 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
366 (rearranged,offsets) = unzip rearranged_w_offsets
370 def2expr StgNoDefault = Nothing
371 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
373 mkAppChain ie result_rep so_far []
375 mkAppChain ie result_rep so_far [a]
376 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
377 mkAppChain ie result_rep so_far (a:as)
378 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
380 mkCasePrim RepI = CasePrimI
381 mkCasePrim RepP = CasePrimP
383 mkCaseAlg RepI = CaseAlgI
384 mkCaseAlg RepP = CaseAlgP
386 -- any var that isn't in scope is turned into a Native
388 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
389 | otherwise = Native (toRdrName var)
393 mkNonRec RepI = NonRecI
394 mkNonRec RepP = NonRecP
396 mkPrimOp RepI = PrimOpI
397 mkPrimOp RepP = PrimOpP
399 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
400 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
401 arg2expr ie (StgLitArg lit) = lit2expr lit
402 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
404 repOfArg :: StgArg -> Rep
405 repOfArg (StgVarArg v) = repOfId v
406 repOfArg (StgLitArg lit) = repOfLit lit
407 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
409 id2VaaRep var = (var, repOfId var)
412 -- ---------------------------------------------------------------------------
413 -- Link interpretables into something we can run
414 -- ---------------------------------------------------------------------------
416 linkIModules :: ClosureEnv -- incoming global closure env; returned updated
417 -> ItblEnv -- incoming global itbl env; returned updated
418 -> [([UnlinkedIBind], ItblEnv)]
419 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
420 linkIModules gce gie mods = do
421 let (bindss, ies) = unzip mods
422 binds = concat bindss
423 top_level_binders = map (toRdrName.binder) binds
424 final_gie = foldr plusFM gie ies
427 new_gce = addListToFM gce (zip top_level_binders new_rhss)
428 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
429 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
430 new_binds = linkIBinds final_gie new_gce binds
432 return (new_binds, final_gie, new_gce)
435 -- We're supposed to augment the environments with the values of any
436 -- external functions/info tables we need as we go along, but that's a
437 -- lot of hassle so for now I'll look up external things as they crop
438 -- up and not cache them in the source symbol tables. The interpreted
439 -- code will still be referenced in the source symbol tables.
441 -- JRS 001025: above comment is probably out of date ... interpret
444 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
445 linkIBinds ie ce binds = map (linkIBind ie ce) binds
447 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
449 linkIExpr ie ce expr = case expr of
451 CaseAlgP bndr expr alts dflt ->
452 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
453 (linkDefault ie ce dflt)
455 CaseAlgI bndr expr alts dflt ->
456 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
457 (linkDefault ie ce dflt)
459 CasePrimP bndr expr alts dflt ->
460 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
461 (linkDefault ie ce dflt)
463 CasePrimI bndr expr alts dflt ->
464 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
465 (linkDefault ie ce dflt)
468 ConApp (lookupCon ie con)
471 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
474 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
476 ConAppPP con arg0 arg1 ->
477 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
479 ConAppPPP con arg0 arg1 arg2 ->
480 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
481 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
483 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
484 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
486 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
487 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
489 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
490 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
496 Native var -> lookupNative ce var
498 VarP v -> lookupVar ce VarP v
499 VarI v -> lookupVar ce VarI v
501 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
502 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
503 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
504 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
506 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
507 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
508 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
509 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
512 case lookupFM ie con of
515 -- try looking up in the object files.
517 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
519 Nothing -> pprPanic "linkIExpr" (ppr con)
521 lookupNative ce var =
522 case lookupFM ce var of
525 -- try looking up in the object files.
526 let lbl = (rdrNameToCLabel var "closure")
527 addr = unsafePerformIO (lookupSymbol lbl) in
528 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
529 Just (A# addr) -> Native (unsafeCoerce# addr)
530 Nothing -> pprPanic "linkIExpr" (ppr var)
532 -- some VarI/VarP refer to top-level interpreted functions; we change
533 -- them into Natives here.
535 case lookupFM ce (toRdrName v) of
539 -- HACK!!! ToDo: cleaner
540 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
541 rdrNameToCLabel rn suffix =
542 _UNPK_(moduleNameFS (rdrNameModule rn))
543 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
545 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
546 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
548 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
549 linkPrimAlt ie ce (AltPrim lit rhs)
550 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
552 linkDefault ie ce Nothing = Nothing
553 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
555 -- ---------------------------------------------------------------------------
556 -- The interpreter proper
557 -- ---------------------------------------------------------------------------
559 -- The dynamic environment contains everything boxed.
560 -- eval* functions which look up values in it will know the
561 -- representation of the thing they are looking up, so they
562 -- can cast/unbox it as necessary.
564 -- ---------------------------------------------------------------------------
565 -- Evaluator for things of boxed (pointer) representation
566 -- ---------------------------------------------------------------------------
568 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
572 -- | trace ("evalP: " ++ showExprTag expr) False
573 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
574 = error "evalP: ?!?!"
577 evalP (Native p) de = unsafeCoerce# p
579 -- First try the dynamic env. If that fails, assume it's a top-level
580 -- binding and look in the static env. That gives an Expr, which we
581 -- must convert to a boxed thingy by applying evalP to it. Because
582 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
583 -- CAFs), it's always safe to use evalP.
585 = case lookupUFM de v of
587 Nothing -> error ("evalP: lookupUFM " ++ show v)
589 -- Deal with application of a function returning a pointer rep
590 -- to arguments of any persuasion. Note that the function itself
591 -- always has pointer rep.
592 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
593 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
594 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
595 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
597 -- Lambdas always return P-rep, but we need to do different things
598 -- depending on both the argument and result representations.
600 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
602 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
604 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
606 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
608 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
610 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
612 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
614 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
616 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
618 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
620 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
622 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
624 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
626 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
628 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
630 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
633 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
634 -- except in the sense that we go on and evaluate the body with whichever
635 -- evaluator was used for the expression as a whole.
636 evalP (NonRecP bind e) de
637 = evalP e (augment_nonrec bind de)
638 evalP (RecP binds b) de
639 = evalP b (augment_rec binds de)
640 evalP (CaseAlgP bndr expr alts def) de
641 = case helper_caseAlg bndr expr alts def de of
642 (rhs, de') -> evalP rhs de'
643 evalP (CasePrimP bndr expr alts def) de
644 = case helper_casePrim bndr expr alts def de of
645 (rhs, de') -> evalP rhs de'
648 -- ConApp can only be handled by evalP
649 evalP (ConApp itbl args) se de
652 -- This appalling hack suggested (gleefully) by SDM
653 -- It is not well typed (needless to say?)
654 loop :: [Expr] -> boxed
656 = trace "loop-empty" (
657 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
660 = trace "loop-not-empty" (
662 RepI -> case evalI a de of i# -> loop as i#
663 RepP -> let p = evalP a de in loop as p
667 evalP (ConAppI (A# itbl) a1) de
668 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
670 evalP (ConApp (A# itbl)) de
671 = mci_make_constr itbl
673 evalP (ConAppP (A# itbl) a1) de
674 = let p1 = evalP a1 de
675 in mci_make_constrP itbl p1
677 evalP (ConAppPP (A# itbl) a1 a2) de
678 = let p1 = evalP a1 de
680 in mci_make_constrPP itbl p1 p2
682 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
683 = let p1 = evalP a1 de
686 in mci_make_constrPPP itbl p1 p2 p3
691 = error ("evalP: unhandled case: " ++ showExprTag other)
693 --------------------------------------------------------
694 --- Evaluator for things of Int# representation
695 --------------------------------------------------------
697 -- Evaluate something which has an unboxed Int rep
698 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
701 -- | trace ("evalI: " ++ showExprTag expr) False
702 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
703 = error "evalI: ?!?!"
705 evalI (LitI i#) de = i#
708 case lookupUFM de v of
709 Just e -> case unsafeCoerce# e of I# i -> i
710 Nothing -> error ("evalI: lookupUFM " ++ show v)
712 -- Deal with application of a function returning an Int# rep
713 -- to arguments of any persuasion. Note that the function itself
714 -- always has pointer rep.
715 evalI (AppII e1 e2) de
716 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
717 evalI (AppPI e1 e2) de
718 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
719 evalI (AppFI e1 e2) de
720 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
721 evalI (AppDI e1 e2) de
722 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
724 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
725 -- except in the sense that we go on and evaluate the body with whichever
726 -- evaluator was used for the expression as a whole.
727 evalI (NonRecI bind b) de
728 = evalI b (augment_nonrec bind de)
729 evalI (RecI binds b) de
730 = evalI b (augment_rec binds de)
731 evalI (CaseAlgI bndr expr alts def) de
732 = case helper_caseAlg bndr expr alts def de of
733 (rhs, de') -> evalI rhs de'
734 evalI (CasePrimI bndr expr alts def) de
735 = case helper_casePrim bndr expr alts def de of
736 (rhs, de') -> evalI rhs de'
738 -- evalI can't be applied to a lambda term, by defn, since those
741 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
742 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
744 --evalI (NonRec (IBind v e) b) de
745 -- = evalI b (augment de v (eval e de))
748 = error ("evalI: unhandled case: " ++ showExprTag other)
750 --------------------------------------------------------
751 --- Evaluator for things of Float# representation
752 --------------------------------------------------------
754 -- Evaluate something which has an unboxed Int rep
755 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
758 -- | trace ("evalF: " ++ showExprTag expr) False
759 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
760 = error "evalF: ?!?!"
762 evalF (LitF f#) de = f#
765 case lookupUFM de v of
766 Just e -> case unsafeCoerce# e of F# i -> i
767 Nothing -> error ("evalF: lookupUFM " ++ show v)
769 -- Deal with application of a function returning an Int# rep
770 -- to arguments of any persuasion. Note that the function itself
771 -- always has pointer rep.
772 evalF (AppIF e1 e2) de
773 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
774 evalF (AppPF e1 e2) de
775 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
776 evalF (AppFF e1 e2) de
777 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
778 evalF (AppDF e1 e2) de
779 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
781 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
782 -- except in the sense that we go on and evaluate the body with whichever
783 -- evaluator was used for the expression as a whole.
784 evalF (NonRecF bind b) de
785 = evalF b (augment_nonrec bind de)
786 evalF (RecF binds b) de
787 = evalF b (augment_rec binds de)
788 evalF (CaseAlgF bndr expr alts def) de
789 = case helper_caseAlg bndr expr alts def de of
790 (rhs, de') -> evalF rhs de'
791 evalF (CasePrimF bndr expr alts def) de
792 = case helper_casePrim bndr expr alts def de of
793 (rhs, de') -> evalF rhs de'
795 -- evalF can't be applied to a lambda term, by defn, since those
798 evalF (PrimOpF op _) de
799 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
802 = error ("evalF: unhandled case: " ++ showExprTag other)
804 --------------------------------------------------------
805 --- Evaluator for things of Double# representation
806 --------------------------------------------------------
808 -- Evaluate something which has an unboxed Int rep
809 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
812 -- | trace ("evalD: " ++ showExprTag expr) False
813 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
814 = error "evalD: ?!?!"
816 evalD (LitD d#) de = d#
819 case lookupUFM de v of
820 Just e -> case unsafeCoerce# e of D# i -> i
821 Nothing -> error ("evalD: lookupUFM " ++ show v)
823 -- Deal with application of a function returning an Int# rep
824 -- to arguments of any persuasion. Note that the function itself
825 -- always has pointer rep.
826 evalD (AppID e1 e2) de
827 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
828 evalD (AppPD e1 e2) de
829 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
830 evalD (AppFD e1 e2) de
831 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
832 evalD (AppDD e1 e2) de
833 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
835 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
836 -- except in the sense that we go on and evaluate the body with whichever
837 -- evaluator was used for the expression as a whole.
838 evalD (NonRecD bind b) de
839 = evalD b (augment_nonrec bind de)
840 evalD (RecD binds b) de
841 = evalD b (augment_rec binds de)
842 evalD (CaseAlgD bndr expr alts def) de
843 = case helper_caseAlg bndr expr alts def de of
844 (rhs, de') -> evalD rhs de'
845 evalD (CasePrimD bndr expr alts def) de
846 = case helper_casePrim bndr expr alts def de of
847 (rhs, de') -> evalD rhs de'
849 -- evalD can't be applied to a lambda term, by defn, since those
852 evalD (PrimOpD op _) de
853 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
856 = error ("evalD: unhandled case: " ++ showExprTag other)
858 --------------------------------------------------------
859 --- Helper bits and pieces
860 --------------------------------------------------------
862 -- Find the Rep of any Expr
863 repOf :: LinkedIExpr -> Rep
865 repOf (LamPP _ _) = RepP
866 repOf (LamPI _ _) = RepP
867 repOf (LamPF _ _) = RepP
868 repOf (LamPD _ _) = RepP
869 repOf (LamIP _ _) = RepP
870 repOf (LamII _ _) = RepP
871 repOf (LamIF _ _) = RepP
872 repOf (LamID _ _) = RepP
873 repOf (LamFP _ _) = RepP
874 repOf (LamFI _ _) = RepP
875 repOf (LamFF _ _) = RepP
876 repOf (LamFD _ _) = RepP
877 repOf (LamDP _ _) = RepP
878 repOf (LamDI _ _) = RepP
879 repOf (LamDF _ _) = RepP
880 repOf (LamDD _ _) = RepP
882 repOf (AppPP _ _) = RepP
883 repOf (AppPI _ _) = RepI
884 repOf (AppPF _ _) = RepF
885 repOf (AppPD _ _) = RepD
886 repOf (AppIP _ _) = RepP
887 repOf (AppII _ _) = RepI
888 repOf (AppIF _ _) = RepF
889 repOf (AppID _ _) = RepD
890 repOf (AppFP _ _) = RepP
891 repOf (AppFI _ _) = RepI
892 repOf (AppFF _ _) = RepF
893 repOf (AppFD _ _) = RepD
894 repOf (AppDP _ _) = RepP
895 repOf (AppDI _ _) = RepI
896 repOf (AppDF _ _) = RepF
897 repOf (AppDD _ _) = RepD
899 repOf (NonRecP _ _) = RepP
900 repOf (NonRecI _ _) = RepI
901 repOf (NonRecF _ _) = RepF
902 repOf (NonRecD _ _) = RepD
904 repOf (LitI _) = RepI
905 repOf (LitF _) = RepF
906 repOf (LitD _) = RepD
908 repOf (VarP _) = RepI
909 repOf (VarI _) = RepI
910 repOf (VarF _) = RepF
911 repOf (VarD _) = RepD
913 repOf (PrimOpP _ _) = RepP
914 repOf (PrimOpI _ _) = RepI
915 repOf (PrimOpF _ _) = RepF
916 repOf (PrimOpD _ _) = RepD
918 repOf (ConApp _) = RepP
919 repOf (ConAppI _ _) = RepP
920 repOf (ConAppP _ _) = RepP
921 repOf (ConAppPP _ _ _) = RepP
922 repOf (ConAppPPP _ _ _ _) = RepP
924 repOf (CaseAlgP _ _ _ _) = RepP
925 repOf (CaseAlgI _ _ _ _) = RepI
926 repOf (CaseAlgF _ _ _ _) = RepF
927 repOf (CaseAlgD _ _ _ _) = RepD
929 repOf (CasePrimP _ _ _ _) = RepP
930 repOf (CasePrimI _ _ _ _) = RepI
931 repOf (CasePrimF _ _ _ _) = RepF
932 repOf (CasePrimD _ _ _ _) = RepD
935 = error ("repOf: unhandled case: " ++ showExprTag other)
937 -- how big (in words) is one of these
938 repSizeW :: Rep -> Int
943 -- Evaluate an expression, using the appropriate evaluator,
944 -- then box up the result. Note that it's only safe to use this
945 -- to create values to put in the environment. You can't use it
946 -- to create a value which might get passed to native code since that
947 -- code will have no idea that unboxed things have been boxed.
948 eval :: LinkedIExpr -> UniqFM boxed -> boxed
951 RepI -> unsafeCoerce# (I# (evalI expr de))
952 RepP -> evalP expr de
953 RepF -> unsafeCoerce# (F# (evalF expr de))
954 RepD -> unsafeCoerce# (D# (evalD expr de))
956 -- Evaluate the scrutinee of a case, select an alternative,
957 -- augment the environment appropriately, and return the alt
958 -- and the augmented environment.
959 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
961 -> (LinkedIExpr, UniqFM boxed)
962 helper_caseAlg bndr expr alts def de
963 = let exprEv = evalP expr de
965 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
966 case select_altAlg (tagOf exprEv) alts def of
967 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
970 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
972 -> (LinkedIExpr, UniqFM boxed)
973 helper_casePrim bndr expr alts def de
975 -- Umm, can expr have any other rep? Yes ...
976 -- CharRep, DoubleRep, FloatRep. What about string reps?
977 RepI -> case evalI expr de of
978 i# -> (select_altPrim alts def (LitI i#),
979 addToUFM de bndr (unsafeCoerce# (I# i#)))
982 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
983 augment_from_constr de con ([],offset)
985 augment_from_constr de con ((v,rep):vs,offset)
988 RepP -> indexPtrOffClosure con offset
989 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
991 augment_from_constr (addToUFM de v v_binding) con
992 (vs,offset + repSizeW rep)
994 -- Augment the environment for a non-recursive let.
995 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
996 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
998 -- Augment the environment for a recursive let.
999 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1000 augment_rec binds de
1001 = let vars = map binder binds
1002 rhss = map bindee binds
1003 rhs_vs = map (\rhs -> eval rhs de') rhss
1004 de' = addListToUFM de (zip vars rhs_vs)
1008 -- a must be a constructor?
1010 tagOf x = I# (dataToTag# x)
1012 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1013 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1014 select_altAlg tag [] (Just def) = ([],def)
1015 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1018 else select_altAlg tag alts def
1020 -- literal may only be a literal, not an arbitrary expression
1021 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1022 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1023 select_altPrim [] (Just def) literal = def
1024 select_altPrim ((AltPrim lit rhs):alts) def literal
1025 = if eqLits lit literal
1027 else select_altPrim alts def literal
1029 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1032 -- a is a constructor
1033 indexPtrOffClosure :: a -> Int -> b
1034 indexPtrOffClosure con (I# offset)
1035 = case indexPtrOffClosure# con offset of (# x #) -> x
1037 indexIntOffClosure :: a -> Int -> Int#
1038 indexIntOffClosure con (I# offset)
1039 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1042 ------------------------------------------------------------------------
1043 --- Manufacturing of info tables for DataCons defined in this module ---
1044 ------------------------------------------------------------------------
1046 -- Make info tables for the data decls in this module
1047 mkITbls :: [TyCon] -> IO ItblEnv
1048 mkITbls [] = return emptyFM
1049 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1050 itbls2 <- mkITbls tcs
1051 return (itbls `plusFM` itbls2)
1053 mkITbl :: TyCon -> IO ItblEnv
1055 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1057 | not (isDataTyCon tc)
1059 | n == length dcs -- paranoia; this is an assertion.
1060 = make_constr_itbls dcs
1062 dcs = tyConDataCons tc
1063 n = tyConFamilySize tc
1066 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1068 -- Assumes constructors are numbered from zero, not one
1069 make_constr_itbls :: [DataCon] -> IO ItblEnv
1070 make_constr_itbls cons
1072 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1073 return (listToFM is)
1075 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1076 return (listToFM is)
1078 mk_vecret_itbl (dcon, conNo)
1079 = mk_itbl dcon conNo (vecret_entry conNo)
1080 mk_dirret_itbl (dcon, conNo)
1081 = mk_itbl dcon conNo mci_constr_entry
1083 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1084 mk_itbl dcon conNo entry_addr
1085 = let (tot_wds, ptr_wds, _)
1086 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1088 nptrs = tot_wds - ptr_wds
1089 itbl = StgInfoTable {
1090 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1091 tipe = fromIntegral cONSTR,
1092 srtlen = fromIntegral conNo,
1093 code0 = fromIntegral code0, code1 = fromIntegral code1,
1094 code2 = fromIntegral code2, code3 = fromIntegral code3,
1095 code4 = fromIntegral code4, code5 = fromIntegral code5,
1096 code6 = fromIntegral code6, code7 = fromIntegral code7
1098 -- Make a piece of code to jump to "entry_label".
1099 -- This is the only arch-dependent bit.
1100 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1101 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1103 -- B8 ZZ YY XX WW FF E0
1104 (code0,code1,code2,code3,code4,code5,code6,code7)
1105 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1106 byte 2 entry_addr_w, byte 3 entry_addr_w,
1110 entry_addr_w :: Word32
1111 entry_addr_w = fromIntegral (addrToInt entry_addr)
1113 do addr <- mallocElem itbl
1114 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1115 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1116 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1118 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1121 byte :: Int -> Word32 -> Word32
1122 byte 0 w = w .&. 0xFF
1123 byte 1 w = (w `shiftR` 8) .&. 0xFF
1124 byte 2 w = (w `shiftR` 16) .&. 0xFF
1125 byte 3 w = (w `shiftR` 24) .&. 0xFF
1128 vecret_entry 0 = mci_constr1_entry
1129 vecret_entry 1 = mci_constr2_entry
1130 vecret_entry 2 = mci_constr3_entry
1131 vecret_entry 3 = mci_constr4_entry
1132 vecret_entry 4 = mci_constr5_entry
1133 vecret_entry 5 = mci_constr6_entry
1134 vecret_entry 6 = mci_constr7_entry
1135 vecret_entry 7 = mci_constr8_entry
1137 -- entry point for direct returns for created constr itbls
1138 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1139 -- and the 8 vectored ones
1140 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1141 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1142 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1143 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1144 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1145 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1146 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1147 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1151 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1154 -- Ultra-minimalist version specially for constructors
1155 data StgInfoTable = StgInfoTable {
1160 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1164 instance Storable StgInfoTable where
1167 = (sum . map (\f -> f itbl))
1168 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1169 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1170 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1173 = (sum . map (\f -> f itbl))
1174 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1175 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1176 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1179 = do a1 <- store (ptrs itbl) a0
1180 a2 <- store (nptrs itbl) a1
1181 a3 <- store (tipe itbl) a2
1182 a4 <- store (srtlen itbl) a3
1183 a5 <- store (code0 itbl) a4
1184 a6 <- store (code1 itbl) a5
1185 a7 <- store (code2 itbl) a6
1186 a8 <- store (code3 itbl) a7
1187 a9 <- store (code4 itbl) a8
1188 aA <- store (code5 itbl) a9
1189 aB <- store (code6 itbl) aA
1190 aC <- store (code7 itbl) aB
1194 = do (a1,ptrs) <- load a0
1195 (a2,nptrs) <- load a1
1196 (a3,tipe) <- load a2
1197 (a4,srtlen) <- load a3
1198 (a5,code0) <- load a4
1199 (a6,code1) <- load a5
1200 (a7,code2) <- load a6
1201 (a8,code3) <- load a7
1202 (a9,code4) <- load a8
1203 (aA,code5) <- load a9
1204 (aB,code6) <- load aA
1205 (aC,code7) <- load aB
1206 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1207 srtlen = srtlen, tipe = tipe,
1208 code0 = code0, code1 = code1, code2 = code2,
1209 code3 = code3, code4 = code4, code5 = code5,
1210 code6 = code6, code7 = code7 }
1212 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1213 fieldSz sel x = sizeOf (sel x)
1215 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1216 fieldAl sel x = alignment (sel x)
1218 store :: Storable a => a -> Addr -> IO Addr
1219 store x addr = do poke addr x
1220 return (addr `plusAddr` fromIntegral (sizeOf x))
1222 load :: Storable a => Addr -> IO (Addr, a)
1223 load addr = do x <- peek addr
1224 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1226 -----------------------------------------------------------------------------q
1228 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()