2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
14 {- -----------------------------------------------------------------------------
17 - link should be in the IO monad, so it can modify the symtabs as it
20 - need a way to remove the bindings for a module from the symtabs.
21 maybe the symtabs should be indexed by module first.
23 - change the representation to something less verbose (?).
25 - converting string literals to Addr# is horrible and introduces
26 a memory leak. See if something can be done about this.
28 ----------------------------------------------------------------------------- -}
30 #include "HsVersions.h"
33 import Id ( Id, idPrimRep )
36 import PrimOp ( PrimOp(..) )
37 import PrimRep ( PrimRep(..) )
38 import Literal ( Literal(..) )
39 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
40 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
41 import ClosureInfo ( mkVirtHeapOffsets )
42 import Name ( toRdrName )
46 import {-# SOURCE #-} MCI_make_constr
48 import IOExts ( unsafePerformIO ) -- ToDo: remove
49 import PrelGHC --( unsafeCoerce#, dataToTag#,
50 -- indexPtrOffClosure#, indexWordOffClosure# )
51 import PrelAddr ( Addr(..) )
52 import PrelFloat ( Float(..), Double(..) )
55 import GlaExts ( Int(..) )
56 import Module ( moduleNameFS )
58 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
59 import Class ( Class, classTyCon )
63 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
65 import Panic ( panic )
66 import OccName ( occNameString )
71 -- ---------------------------------------------------------------------------
72 -- Environments needed by the linker
73 -- ---------------------------------------------------------------------------
75 type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable)
76 type ClosureEnv = FiniteMap RdrName HValue
77 emptyClosureEnv = emptyFM
79 -- ---------------------------------------------------------------------------
80 -- Run our STG program through the interpreter
81 -- ---------------------------------------------------------------------------
84 -- To be nuked at some point soon.
85 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
87 -- the bindings need to have a binding for stgMain, and the
88 -- body of it had better represent something of type Int# -> Int#
89 runStgI tycons classes stgbinds
91 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
95 = "-------------------- Unlinked Binds --------------------\n"
96 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
99 hPutStr stderr dbg_txt
101 (linked_binds, ie, ce) <-
102 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
105 = "-------------------- Linked Binds --------------------\n"
106 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
109 hPutStr stderr dbg_txt
112 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
114 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
117 = I# (evalI (AppII stgMain (LitI 0#))
118 emptyUFM{-initial de-}
123 -- ---------------------------------------------------------------------------
124 -- Convert STG to an unlinked interpretable
125 -- ---------------------------------------------------------------------------
127 -- visible from outside
128 stgToInterpSyn :: [StgBinding]
129 -> [TyCon] -> [Class]
130 -> IO ([UnlinkedIBind], ItblEnv)
131 stgToInterpSyn binds local_tycons local_classes
132 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
133 let tycs = local_tycons ++ map classTyCon local_classes
134 itblenv <- mkITbls tycs
135 return (ibinds, itblenv)
138 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
139 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
140 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
141 where ie' = addListToUniqSet ie (map fst vs_n_es)
143 isRec (StgNonRec _ _) = False
144 isRec (StgRec _) = True
146 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
147 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
150 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
151 rhsRep = repOfStgExpr rhs
152 mkLambdas [] = rhsExpr
153 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
154 rhs2expr ie (StgRhsCon ccs dcon args)
155 = conapp2expr ie dcon args
157 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
158 conapp2expr ie dcon args
159 = mkConApp con_rdrname reps exprs
161 con_rdrname = toRdrName dcon
162 exprs = map (arg2expr ie) inHeapOrder
163 reps = map repOfArg inHeapOrder
164 inHeapOrder = toHeapOrder args
166 toHeapOrder :: [StgArg] -> [StgArg]
168 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
169 (rearranged, offsets) = unzip rearranged_w_offsets
173 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
175 -- Handle most common cases specially; do the rest with a generic
176 -- mechanism (deferred till later :)
177 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
178 mkConApp nm [] [] = ConApp nm
179 mkConApp nm [RepI] [a1] = ConAppI nm a1
180 mkConApp nm [RepP] [a1] = ConAppP nm a1
181 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
182 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
183 mkConApp nm reps args
184 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
186 mkLam RepP RepP = LamPP
187 mkLam RepI RepP = LamIP
188 mkLam RepP RepI = LamPI
189 mkLam RepI RepI = LamII
190 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
192 mkApp RepP RepP = AppPP
193 mkApp RepI RepP = AppIP
194 mkApp RepP RepI = AppPI
195 mkApp RepI RepI = AppII
196 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
199 repOfId = primRep2Rep . idPrimRep
204 -- genuine lifted types
207 -- all these are unboxed, fit into a word, and we assume they
208 -- all have the same call/return convention.
216 -- these are pretty dodgy: really pointers, but
217 -- we can't let the compiler build thunks with these reps.
218 ForeignObjRep -> RepP
219 StableNameRep -> RepP
224 other -> pprPanic "primRep2Rep" (ppr other)
226 repOfStgExpr :: StgExpr -> Rep
231 StgCase scrut live liveR bndr srt alts
232 -> case altRhss alts of
233 (a:_) -> repOfStgExpr a
234 [] -> panic "repOfStgExpr: no alts"
238 -> repOfApp ((deNoteType.repType.idType) var) (length args)
240 StgPrimApp op args res_ty
241 -> (primRep2Rep.typePrimRep) res_ty
243 StgLet binds body -> repOfStgExpr body
244 StgLetNoEscape live liveR binds body -> repOfStgExpr body
246 StgConApp con args -> RepP -- by definition
249 -> pprPanic "repOfStgExpr" (ppr other)
251 altRhss (StgAlgAlts tycon alts def)
252 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
253 altRhss (StgPrimAlts tycon alts def)
254 = [rhs | (lit,rhs) <- alts] ++ defRhs def
257 defRhs (StgBindDefault rhs)
260 -- returns the Rep of the result of applying ty to n args.
261 repOfApp :: Type -> Int -> Rep
262 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
263 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
275 MachStr _ -> RepI -- because it's a ptr outside the heap
276 other -> pprPanic "repOfLit" (ppr lit)
278 lit2expr :: Literal -> UnlinkedIExpr
281 MachInt i -> case fromIntegral i of I# i -> LitI i
282 MachWord i -> case fromIntegral i of I# i -> LitI i
283 MachAddr i -> case fromIntegral i of I# i -> LitI i
284 MachChar i -> case fromIntegral i of I# i -> LitI i
285 MachFloat f -> case fromRational f of F# f -> LitF f
286 MachDouble f -> case fromRational f of D# f -> LitD f
289 CharStr s i -> LitI (addr2Int# s)
292 -- sigh, a string in the heap is no good to us. We need a
293 -- static C pointer, since the type of a string literal is
294 -- Addr#. So, copy the string into C land and introduce a
295 -- memory leak at the same time.
297 case unsafePerformIO (do a <- mallocBytes (n+1);
298 strncpy a ba (fromIntegral n);
300 case a of { Ptr a -> return a })
301 of A# a -> LitI (addr2Int# a)
303 _ -> error "StgInterp.lit2expr: unhandled string constant type"
305 other -> pprPanic "lit2expr" (ppr lit)
307 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
311 -> mkVar ie (repOfId var) var
314 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
318 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
319 | repOfStgExpr scrut /= RepP
320 -> mkCasePrim (repOfStgExpr stgexpr)
321 bndr (stg2expr ie scrut)
325 StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
326 | repOfStgExpr scrut == RepP
327 -> mkCaseAlg (repOfStgExpr stgexpr)
328 bndr (stg2expr ie scrut)
332 StgPrimApp op args res_ty
333 -> mkPrimOp (repOfStgExpr stgexpr)
334 op (map (arg2expr ie) args)
337 -> conapp2expr ie dcon args
339 StgLet binds@(StgNonRec v e) body
340 -> mkNonRec (repOfStgExpr stgexpr)
341 (head (translateBind ie binds))
342 (stg2expr (addOneToUniqSet ie v) body)
344 StgLet binds@(StgRec bs) body
345 -> mkRec (repOfStgExpr stgexpr)
346 (translateBind ie binds)
347 (stg2expr (addListToUniqSet ie (map fst bs)) body)
350 -> pprPanic "stg2expr" (ppr stgexpr)
353 = AltPrim (lit2expr lit) (stg2expr ie rhs)
354 doAlgAlt (dcon,vars,uses,rhs)
355 = AltAlg (dataConTag dcon - 1)
356 (map id2VaaRep (toHeapOrder vars))
357 (stg2expr (addListToUniqSet ie vars) rhs)
360 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
361 (rearranged,offsets) = unzip rearranged_w_offsets
365 def2expr StgNoDefault = Nothing
366 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
368 mkAppChain ie result_rep so_far []
370 mkAppChain ie result_rep so_far [a]
371 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
372 mkAppChain ie result_rep so_far (a:as)
373 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
375 mkCasePrim RepI = CasePrimI
376 mkCasePrim RepP = CasePrimP
378 mkCaseAlg RepI = CaseAlgI
379 mkCaseAlg RepP = CaseAlgP
381 -- any var that isn't in scope is turned into a Native
383 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
384 | otherwise = Native (toRdrName var)
388 mkNonRec RepI = NonRecI
389 mkNonRec RepP = NonRecP
391 mkPrimOp RepI = PrimOpI
392 mkPrimOp RepP = PrimOpP
394 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
395 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
396 arg2expr ie (StgLitArg lit) = lit2expr lit
397 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
399 repOfArg :: StgArg -> Rep
400 repOfArg (StgVarArg v) = repOfId v
401 repOfArg (StgLitArg lit) = repOfLit lit
402 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
404 id2VaaRep var = (var, repOfId var)
407 -- ---------------------------------------------------------------------------
408 -- Link interpretables into something we can run
409 -- ---------------------------------------------------------------------------
411 linkIModules :: ClosureEnv -- incoming global closure env; returned updated
412 -> ItblEnv -- incoming global itbl env; returned updated
413 -> [([UnlinkedIBind], ItblEnv)]
414 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
415 linkIModules gce gie mods = do
416 let (bindss, ies) = unzip mods
417 binds = concat bindss
418 top_level_binders = map (toRdrName.binder) binds
419 final_gie = foldr plusFM gie ies
422 new_gce = addListToFM gce (zip top_level_binders new_rhss)
423 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
424 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
425 new_binds = linkIBinds final_gie new_gce binds
427 return (new_binds, final_gie, new_gce)
430 -- We're supposed to augment the environments with the values of any
431 -- external functions/info tables we need as we go along, but that's a
432 -- lot of hassle so for now I'll look up external things as they crop
433 -- up and not cache them in the source symbol tables. The interpreted
434 -- code will still be referenced in the source symbol tables.
436 -- JRS 001025: above comment is probably out of date ... interpret
439 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
440 linkIBinds ie ce binds = map (linkIBind ie ce) binds
442 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
444 linkIExpr ie ce expr = case expr of
446 CaseAlgP bndr expr alts dflt ->
447 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
448 (linkDefault ie ce dflt)
450 CaseAlgI bndr expr alts dflt ->
451 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
452 (linkDefault ie ce dflt)
454 CasePrimP bndr expr alts dflt ->
455 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
456 (linkDefault ie ce dflt)
458 CasePrimI bndr expr alts dflt ->
459 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
460 (linkDefault ie ce dflt)
463 ConApp (lookupCon ie con)
466 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
469 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
471 ConAppPP con arg0 arg1 ->
472 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
474 ConAppPPP con arg0 arg1 arg2 ->
475 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
476 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
478 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
479 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
481 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
482 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
484 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
485 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
491 Native var -> lookupNative ce var
493 VarP v -> lookupVar ce VarP v
494 VarI v -> lookupVar ce VarI v
496 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
497 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
498 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
499 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
501 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
502 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
503 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
504 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
507 case lookupFM ie con of
508 Just (Ptr addr) -> addr
510 -- try looking up in the object files.
512 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
514 Nothing -> pprPanic "linkIExpr" (ppr con)
516 lookupNative ce var =
517 case lookupFM ce var of
520 -- try looking up in the object files.
521 let lbl = (rdrNameToCLabel var "closure")
522 addr = unsafePerformIO (lookupSymbol lbl) in
523 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
524 Just (A# addr) -> Native (unsafeCoerce# addr)
525 Nothing -> pprPanic "linkIExpr" (ppr var)
527 -- some VarI/VarP refer to top-level interpreted functions; we change
528 -- them into Natives here.
530 case lookupFM ce (toRdrName v) of
534 -- HACK!!! ToDo: cleaner
535 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
536 rdrNameToCLabel rn suffix =
537 _UNPK_(moduleNameFS (rdrNameModule rn))
538 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
540 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
541 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
543 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
544 linkPrimAlt ie ce (AltPrim lit rhs)
545 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
547 linkDefault ie ce Nothing = Nothing
548 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
550 -- ---------------------------------------------------------------------------
551 -- The interpreter proper
552 -- ---------------------------------------------------------------------------
554 -- The dynamic environment contains everything boxed.
555 -- eval* functions which look up values in it will know the
556 -- representation of the thing they are looking up, so they
557 -- can cast/unbox it as necessary.
559 -- ---------------------------------------------------------------------------
560 -- Evaluator for things of boxed (pointer) representation
561 -- ---------------------------------------------------------------------------
563 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
567 -- | trace ("evalP: " ++ showExprTag expr) False
568 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
569 = error "evalP: ?!?!"
572 evalP (Native p) de = unsafeCoerce# p
574 -- First try the dynamic env. If that fails, assume it's a top-level
575 -- binding and look in the static env. That gives an Expr, which we
576 -- must convert to a boxed thingy by applying evalP to it. Because
577 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
578 -- CAFs), it's always safe to use evalP.
580 = case lookupUFM de v of
582 Nothing -> error ("evalP: lookupUFM " ++ show v)
584 -- Deal with application of a function returning a pointer rep
585 -- to arguments of any persuasion. Note that the function itself
586 -- always has pointer rep.
587 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
588 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
589 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
590 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
592 -- Lambdas always return P-rep, but we need to do different things
593 -- depending on both the argument and result representations.
595 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
597 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
599 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
601 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
603 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
605 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
607 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
609 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
611 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
613 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
615 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
617 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
619 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
621 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
623 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
625 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
628 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
629 -- except in the sense that we go on and evaluate the body with whichever
630 -- evaluator was used for the expression as a whole.
631 evalP (NonRecP bind e) de
632 = evalP e (augment_nonrec bind de)
633 evalP (RecP binds b) de
634 = evalP b (augment_rec binds de)
635 evalP (CaseAlgP bndr expr alts def) de
636 = case helper_caseAlg bndr expr alts def de of
637 (rhs, de') -> evalP rhs de'
638 evalP (CasePrimP bndr expr alts def) de
639 = case helper_casePrim bndr expr alts def de of
640 (rhs, de') -> evalP rhs de'
643 -- ConApp can only be handled by evalP
644 evalP (ConApp itbl args) se de
647 -- This appalling hack suggested (gleefully) by SDM
648 -- It is not well typed (needless to say?)
649 loop :: [Expr] -> boxed
651 = trace "loop-empty" (
652 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
655 = trace "loop-not-empty" (
657 RepI -> case evalI a de of i# -> loop as i#
658 RepP -> let p = evalP a de in loop as p
662 evalP (ConAppI (A# itbl) a1) de
663 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
665 evalP (ConApp (A# itbl)) de
666 = mci_make_constr itbl
668 evalP (ConAppP (A# itbl) a1) de
669 = let p1 = evalP a1 de
670 in mci_make_constrP itbl p1
672 evalP (ConAppPP (A# itbl) a1 a2) de
673 = let p1 = evalP a1 de
675 in mci_make_constrPP itbl p1 p2
677 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
678 = let p1 = evalP a1 de
681 in mci_make_constrPPP itbl p1 p2 p3
686 = error ("evalP: unhandled case: " ++ showExprTag other)
688 --------------------------------------------------------
689 --- Evaluator for things of Int# representation
690 --------------------------------------------------------
692 -- Evaluate something which has an unboxed Int rep
693 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
696 -- | trace ("evalI: " ++ showExprTag expr) False
697 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
698 = error "evalI: ?!?!"
700 evalI (LitI i#) de = i#
703 case lookupUFM de v of
704 Just e -> case unsafeCoerce# e of I# i -> i
705 Nothing -> error ("evalI: lookupUFM " ++ show v)
707 -- Deal with application of a function returning an Int# rep
708 -- to arguments of any persuasion. Note that the function itself
709 -- always has pointer rep.
710 evalI (AppII e1 e2) de
711 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
712 evalI (AppPI e1 e2) de
713 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
714 evalI (AppFI e1 e2) de
715 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
716 evalI (AppDI e1 e2) de
717 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
719 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
720 -- except in the sense that we go on and evaluate the body with whichever
721 -- evaluator was used for the expression as a whole.
722 evalI (NonRecI bind b) de
723 = evalI b (augment_nonrec bind de)
724 evalI (RecI binds b) de
725 = evalI b (augment_rec binds de)
726 evalI (CaseAlgI bndr expr alts def) de
727 = case helper_caseAlg bndr expr alts def de of
728 (rhs, de') -> evalI rhs de'
729 evalI (CasePrimI bndr expr alts def) de
730 = case helper_casePrim bndr expr alts def de of
731 (rhs, de') -> evalI rhs de'
733 -- evalI can't be applied to a lambda term, by defn, since those
736 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
737 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
739 --evalI (NonRec (IBind v e) b) de
740 -- = evalI b (augment de v (eval e de))
743 = error ("evalI: unhandled case: " ++ showExprTag other)
745 --------------------------------------------------------
746 --- Evaluator for things of Float# representation
747 --------------------------------------------------------
749 -- Evaluate something which has an unboxed Int rep
750 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
753 -- | trace ("evalF: " ++ showExprTag expr) False
754 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
755 = error "evalF: ?!?!"
757 evalF (LitF f#) de = f#
760 case lookupUFM de v of
761 Just e -> case unsafeCoerce# e of F# i -> i
762 Nothing -> error ("evalF: lookupUFM " ++ show v)
764 -- Deal with application of a function returning an Int# rep
765 -- to arguments of any persuasion. Note that the function itself
766 -- always has pointer rep.
767 evalF (AppIF e1 e2) de
768 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
769 evalF (AppPF e1 e2) de
770 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
771 evalF (AppFF e1 e2) de
772 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
773 evalF (AppDF e1 e2) de
774 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
776 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
777 -- except in the sense that we go on and evaluate the body with whichever
778 -- evaluator was used for the expression as a whole.
779 evalF (NonRecF bind b) de
780 = evalF b (augment_nonrec bind de)
781 evalF (RecF binds b) de
782 = evalF b (augment_rec binds de)
783 evalF (CaseAlgF bndr expr alts def) de
784 = case helper_caseAlg bndr expr alts def de of
785 (rhs, de') -> evalF rhs de'
786 evalF (CasePrimF bndr expr alts def) de
787 = case helper_casePrim bndr expr alts def de of
788 (rhs, de') -> evalF rhs de'
790 -- evalF can't be applied to a lambda term, by defn, since those
793 evalF (PrimOpF op _) de
794 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
797 = error ("evalF: unhandled case: " ++ showExprTag other)
799 --------------------------------------------------------
800 --- Evaluator for things of Double# representation
801 --------------------------------------------------------
803 -- Evaluate something which has an unboxed Int rep
804 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
807 -- | trace ("evalD: " ++ showExprTag expr) False
808 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
809 = error "evalD: ?!?!"
811 evalD (LitD d#) de = d#
814 case lookupUFM de v of
815 Just e -> case unsafeCoerce# e of D# i -> i
816 Nothing -> error ("evalD: lookupUFM " ++ show v)
818 -- Deal with application of a function returning an Int# rep
819 -- to arguments of any persuasion. Note that the function itself
820 -- always has pointer rep.
821 evalD (AppID e1 e2) de
822 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
823 evalD (AppPD e1 e2) de
824 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
825 evalD (AppFD e1 e2) de
826 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
827 evalD (AppDD e1 e2) de
828 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
830 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
831 -- except in the sense that we go on and evaluate the body with whichever
832 -- evaluator was used for the expression as a whole.
833 evalD (NonRecD bind b) de
834 = evalD b (augment_nonrec bind de)
835 evalD (RecD binds b) de
836 = evalD b (augment_rec binds de)
837 evalD (CaseAlgD bndr expr alts def) de
838 = case helper_caseAlg bndr expr alts def de of
839 (rhs, de') -> evalD rhs de'
840 evalD (CasePrimD bndr expr alts def) de
841 = case helper_casePrim bndr expr alts def de of
842 (rhs, de') -> evalD rhs de'
844 -- evalD can't be applied to a lambda term, by defn, since those
847 evalD (PrimOpD op _) de
848 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
851 = error ("evalD: unhandled case: " ++ showExprTag other)
853 --------------------------------------------------------
854 --- Helper bits and pieces
855 --------------------------------------------------------
857 -- Find the Rep of any Expr
858 repOf :: LinkedIExpr -> Rep
860 repOf (LamPP _ _) = RepP
861 repOf (LamPI _ _) = RepP
862 repOf (LamPF _ _) = RepP
863 repOf (LamPD _ _) = RepP
864 repOf (LamIP _ _) = RepP
865 repOf (LamII _ _) = RepP
866 repOf (LamIF _ _) = RepP
867 repOf (LamID _ _) = RepP
868 repOf (LamFP _ _) = RepP
869 repOf (LamFI _ _) = RepP
870 repOf (LamFF _ _) = RepP
871 repOf (LamFD _ _) = RepP
872 repOf (LamDP _ _) = RepP
873 repOf (LamDI _ _) = RepP
874 repOf (LamDF _ _) = RepP
875 repOf (LamDD _ _) = RepP
877 repOf (AppPP _ _) = RepP
878 repOf (AppPI _ _) = RepI
879 repOf (AppPF _ _) = RepF
880 repOf (AppPD _ _) = RepD
881 repOf (AppIP _ _) = RepP
882 repOf (AppII _ _) = RepI
883 repOf (AppIF _ _) = RepF
884 repOf (AppID _ _) = RepD
885 repOf (AppFP _ _) = RepP
886 repOf (AppFI _ _) = RepI
887 repOf (AppFF _ _) = RepF
888 repOf (AppFD _ _) = RepD
889 repOf (AppDP _ _) = RepP
890 repOf (AppDI _ _) = RepI
891 repOf (AppDF _ _) = RepF
892 repOf (AppDD _ _) = RepD
894 repOf (NonRecP _ _) = RepP
895 repOf (NonRecI _ _) = RepI
896 repOf (NonRecF _ _) = RepF
897 repOf (NonRecD _ _) = RepD
899 repOf (LitI _) = RepI
900 repOf (LitF _) = RepF
901 repOf (LitD _) = RepD
903 repOf (VarP _) = RepI
904 repOf (VarI _) = RepI
905 repOf (VarF _) = RepF
906 repOf (VarD _) = RepD
908 repOf (PrimOpP _ _) = RepP
909 repOf (PrimOpI _ _) = RepI
910 repOf (PrimOpF _ _) = RepF
911 repOf (PrimOpD _ _) = RepD
913 repOf (ConApp _) = RepP
914 repOf (ConAppI _ _) = RepP
915 repOf (ConAppP _ _) = RepP
916 repOf (ConAppPP _ _ _) = RepP
917 repOf (ConAppPPP _ _ _ _) = RepP
919 repOf (CaseAlgP _ _ _ _) = RepP
920 repOf (CaseAlgI _ _ _ _) = RepI
921 repOf (CaseAlgF _ _ _ _) = RepF
922 repOf (CaseAlgD _ _ _ _) = RepD
924 repOf (CasePrimP _ _ _ _) = RepP
925 repOf (CasePrimI _ _ _ _) = RepI
926 repOf (CasePrimF _ _ _ _) = RepF
927 repOf (CasePrimD _ _ _ _) = RepD
930 = error ("repOf: unhandled case: " ++ showExprTag other)
932 -- how big (in words) is one of these
933 repSizeW :: Rep -> Int
938 -- Evaluate an expression, using the appropriate evaluator,
939 -- then box up the result. Note that it's only safe to use this
940 -- to create values to put in the environment. You can't use it
941 -- to create a value which might get passed to native code since that
942 -- code will have no idea that unboxed things have been boxed.
943 eval :: LinkedIExpr -> UniqFM boxed -> boxed
946 RepI -> unsafeCoerce# (I# (evalI expr de))
947 RepP -> evalP expr de
948 RepF -> unsafeCoerce# (F# (evalF expr de))
949 RepD -> unsafeCoerce# (D# (evalD expr de))
951 -- Evaluate the scrutinee of a case, select an alternative,
952 -- augment the environment appropriately, and return the alt
953 -- and the augmented environment.
954 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
956 -> (LinkedIExpr, UniqFM boxed)
957 helper_caseAlg bndr expr alts def de
958 = let exprEv = evalP expr de
960 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
961 case select_altAlg (tagOf exprEv) alts def of
962 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
965 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
967 -> (LinkedIExpr, UniqFM boxed)
968 helper_casePrim bndr expr alts def de
970 -- Umm, can expr have any other rep? Yes ...
971 -- CharRep, DoubleRep, FloatRep. What about string reps?
972 RepI -> case evalI expr de of
973 i# -> (select_altPrim alts def (LitI i#),
974 addToUFM de bndr (unsafeCoerce# (I# i#)))
977 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
978 augment_from_constr de con ([],offset)
980 augment_from_constr de con ((v,rep):vs,offset)
983 RepP -> indexPtrOffClosure con offset
984 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
986 augment_from_constr (addToUFM de v v_binding) con
987 (vs,offset + repSizeW rep)
989 -- Augment the environment for a non-recursive let.
990 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
991 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
993 -- Augment the environment for a recursive let.
994 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
996 = let vars = map binder binds
997 rhss = map bindee binds
998 rhs_vs = map (\rhs -> eval rhs de') rhss
999 de' = addListToUFM de (zip vars rhs_vs)
1003 -- a must be a constructor?
1005 tagOf x = I# (dataToTag# x)
1007 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1008 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1009 select_altAlg tag [] (Just def) = ([],def)
1010 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1013 else select_altAlg tag alts def
1015 -- literal may only be a literal, not an arbitrary expression
1016 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1017 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1018 select_altPrim [] (Just def) literal = def
1019 select_altPrim ((AltPrim lit rhs):alts) def literal
1020 = if eqLits lit literal
1022 else select_altPrim alts def literal
1024 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1027 -- a is a constructor
1028 indexPtrOffClosure :: a -> Int -> b
1029 indexPtrOffClosure con (I# offset)
1030 = case indexPtrOffClosure# con offset of (# x #) -> x
1032 indexIntOffClosure :: a -> Int -> Int#
1033 indexIntOffClosure con (I# offset)
1034 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1037 ------------------------------------------------------------------------
1038 --- Manufacturing of info tables for DataCons defined in this module ---
1039 ------------------------------------------------------------------------
1041 #if __GLASGOW_HASKELL__ <= 408
1044 type ItblPtr = Ptr StgInfoTable
1047 -- Make info tables for the data decls in this module
1048 mkITbls :: [TyCon] -> IO ItblEnv
1049 mkITbls [] = return emptyFM
1050 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1051 itbls2 <- mkITbls tcs
1052 return (itbls `plusFM` itbls2)
1054 mkITbl :: TyCon -> IO ItblEnv
1056 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1058 | not (isDataTyCon tc)
1060 | n == length dcs -- paranoia; this is an assertion.
1061 = make_constr_itbls dcs
1063 dcs = tyConDataCons tc
1064 n = tyConFamilySize tc
1067 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1069 -- Assumes constructors are numbered from zero, not one
1070 make_constr_itbls :: [DataCon] -> IO ItblEnv
1071 make_constr_itbls cons
1073 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1074 return (listToFM is)
1076 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1077 return (listToFM is)
1079 mk_vecret_itbl (dcon, conNo)
1080 = mk_itbl dcon conNo (vecret_entry conNo)
1081 mk_dirret_itbl (dcon, conNo)
1082 = mk_itbl dcon conNo mci_constr_entry
1084 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
1085 mk_itbl dcon conNo entry_addr
1086 = let (tot_wds, ptr_wds, _)
1087 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1089 nptrs = tot_wds - ptr_wds
1090 itbl = StgInfoTable {
1091 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1092 tipe = fromIntegral cONSTR,
1093 srtlen = fromIntegral conNo,
1094 code0 = fromIntegral code0, code1 = fromIntegral code1,
1095 code2 = fromIntegral code2, code3 = fromIntegral code3,
1096 code4 = fromIntegral code4, code5 = fromIntegral code5,
1097 code6 = fromIntegral code6, code7 = fromIntegral code7
1099 -- Make a piece of code to jump to "entry_label".
1100 -- This is the only arch-dependent bit.
1101 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1102 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1104 -- B8 ZZ YY XX WW FF E0
1105 (code0,code1,code2,code3,code4,code5,code6,code7)
1106 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1107 byte 2 entry_addr_w, byte 3 entry_addr_w,
1111 entry_addr_w :: Word32
1112 entry_addr_w = fromIntegral (addrToInt entry_addr)
1115 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1116 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1117 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1119 return (toRdrName dcon, addr `plusPtr` 8)
1122 byte :: Int -> Word32 -> Word32
1123 byte 0 w = w .&. 0xFF
1124 byte 1 w = (w `shiftR` 8) .&. 0xFF
1125 byte 2 w = (w `shiftR` 16) .&. 0xFF
1126 byte 3 w = (w `shiftR` 24) .&. 0xFF
1129 vecret_entry 0 = mci_constr1_entry
1130 vecret_entry 1 = mci_constr2_entry
1131 vecret_entry 2 = mci_constr3_entry
1132 vecret_entry 3 = mci_constr4_entry
1133 vecret_entry 4 = mci_constr5_entry
1134 vecret_entry 5 = mci_constr6_entry
1135 vecret_entry 6 = mci_constr7_entry
1136 vecret_entry 7 = mci_constr8_entry
1138 -- entry point for direct returns for created constr itbls
1139 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1140 -- and the 8 vectored ones
1141 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1142 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1143 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1144 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1145 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1146 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1147 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1148 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1152 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1155 -- Ultra-minimalist version specially for constructors
1156 data StgInfoTable = StgInfoTable {
1161 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1165 instance Storable StgInfoTable where
1168 = (sum . map (\f -> f itbl))
1169 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1170 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1171 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1174 = (sum . map (\f -> f itbl))
1175 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1176 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1177 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1180 = do a1 <- store (ptrs itbl) (castPtr a0)
1181 a2 <- store (nptrs itbl) a1
1182 a3 <- store (tipe itbl) a2
1183 a4 <- store (srtlen itbl) a3
1184 a5 <- store (code0 itbl) a4
1185 a6 <- store (code1 itbl) a5
1186 a7 <- store (code2 itbl) a6
1187 a8 <- store (code3 itbl) a7
1188 a9 <- store (code4 itbl) a8
1189 aA <- store (code5 itbl) a9
1190 aB <- store (code6 itbl) aA
1191 aC <- store (code7 itbl) aB
1195 = do (a1,ptrs) <- load (castPtr a0)
1196 (a2,nptrs) <- load a1
1197 (a3,tipe) <- load a2
1198 (a4,srtlen) <- load a3
1199 (a5,code0) <- load a4
1200 (a6,code1) <- load a5
1201 (a7,code2) <- load a6
1202 (a8,code3) <- load a7
1203 (a9,code4) <- load a8
1204 (aA,code5) <- load a9
1205 (aB,code6) <- load aA
1206 (aC,code7) <- load aB
1207 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1208 srtlen = srtlen, tipe = tipe,
1209 code0 = code0, code1 = code1, code2 = code2,
1210 code3 = code3, code4 = code4, code5 = code5,
1211 code6 = code6, code7 = code7 }
1213 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1214 fieldSz sel x = sizeOf (sel x)
1216 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1217 fieldAl sel x = alignment (sel x)
1219 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1220 store x addr = do poke addr x
1221 return (castPtr (addr `plusPtr` sizeOf x))
1223 load :: Storable a => Ptr a -> IO (Ptr b, a)
1224 load addr = do x <- peek addr
1225 return (castPtr (addr `plusPtr` sizeOf x), x)
1227 -----------------------------------------------------------------------------q
1229 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()