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
78 -- ---------------------------------------------------------------------------
79 -- Run our STG program through the interpreter
80 -- ---------------------------------------------------------------------------
83 -- To be nuked at some point soon.
84 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
86 -- the bindings need to have a binding for stgMain, and the
87 -- body of it had better represent something of type Int# -> Int#
88 runStgI tycons classes stgbinds
90 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
94 = "-------------------- Unlinked Binds --------------------\n"
95 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
98 hPutStr stderr dbg_txt
100 (linked_binds, ie, ce) <-
101 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
104 = "-------------------- Linked Binds --------------------\n"
105 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
108 hPutStr stderr dbg_txt
111 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
113 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
116 = I# (evalI (AppII stgMain (LitI 0#))
117 emptyUFM{-initial de-}
122 -- ---------------------------------------------------------------------------
123 -- Convert STG to an unlinked interpretable
124 -- ---------------------------------------------------------------------------
126 -- visible from outside
127 stgToInterpSyn :: [StgBinding]
128 -> [TyCon] -> [Class]
129 -> IO ([UnlinkedIBind], ItblEnv)
130 stgToInterpSyn binds local_tycons local_classes
131 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
132 let tycs = local_tycons ++ map classTyCon local_classes
133 itblenv <- mkITbls tycs
134 return (ibinds, itblenv)
137 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
138 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
139 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
140 where ie' = addListToUniqSet ie (map fst vs_n_es)
142 isRec (StgNonRec _ _) = False
143 isRec (StgRec _) = True
145 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
146 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
149 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
150 rhsRep = repOfStgExpr rhs
151 mkLambdas [] = rhsExpr
152 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
153 rhs2expr ie (StgRhsCon ccs dcon args)
154 = conapp2expr ie dcon args
156 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
157 conapp2expr ie dcon args
158 = mkConApp con_rdrname reps exprs
160 con_rdrname = toRdrName dcon
161 exprs = map (arg2expr ie) inHeapOrder
162 reps = map repOfArg inHeapOrder
163 inHeapOrder = toHeapOrder args
165 toHeapOrder :: [StgArg] -> [StgArg]
167 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
168 (rearranged, offsets) = unzip rearranged_w_offsets
172 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
174 -- Handle most common cases specially; do the rest with a generic
175 -- mechanism (deferred till later :)
176 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
177 mkConApp nm [] [] = ConApp nm
178 mkConApp nm [RepI] [a1] = ConAppI nm a1
179 mkConApp nm [RepP] [a1] = ConAppP nm a1
180 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
181 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
182 mkConApp nm reps args
183 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
185 mkLam RepP RepP = LamPP
186 mkLam RepI RepP = LamIP
187 mkLam RepP RepI = LamPI
188 mkLam RepI RepI = LamII
189 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
191 mkApp RepP RepP = AppPP
192 mkApp RepI RepP = AppIP
193 mkApp RepP RepI = AppPI
194 mkApp RepI RepI = AppII
195 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
198 repOfId = primRep2Rep . idPrimRep
203 -- genuine lifted types
206 -- all these are unboxed, fit into a word, and we assume they
207 -- all have the same call/return convention.
215 -- these are pretty dodgy: really pointers, but
216 -- we can't let the compiler build thunks with these reps.
217 ForeignObjRep -> RepP
218 StableNameRep -> RepP
223 other -> pprPanic "primRep2Rep" (ppr other)
225 repOfStgExpr :: StgExpr -> Rep
230 StgCase scrut live liveR bndr srt alts
231 -> case altRhss alts of
232 (a:_) -> repOfStgExpr a
233 [] -> panic "repOfStgExpr: no alts"
237 -> repOfApp ((deNoteType.repType.idType) var) (length args)
239 StgPrimApp op args res_ty
240 -> (primRep2Rep.typePrimRep) res_ty
242 StgLet binds body -> repOfStgExpr body
243 StgLetNoEscape live liveR binds body -> repOfStgExpr body
245 StgConApp con args -> RepP -- by definition
248 -> pprPanic "repOfStgExpr" (ppr other)
250 altRhss (StgAlgAlts ty alts def)
251 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
252 altRhss (StgPrimAlts ty alts def)
253 = [rhs | (lit,rhs) <- alts] ++ defRhs def
256 defRhs (StgBindDefault rhs)
259 -- returns the Rep of the result of applying ty to n args.
260 repOfApp :: Type -> Int -> Rep
261 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
262 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
274 MachStr _ -> RepI -- because it's a ptr outside the heap
275 other -> pprPanic "repOfLit" (ppr lit)
277 lit2expr :: Literal -> UnlinkedIExpr
280 MachInt i -> case fromIntegral i of I# i -> LitI i
281 MachWord i -> case fromIntegral i of I# i -> LitI i
282 MachAddr i -> case fromIntegral i of I# i -> LitI i
283 MachChar i -> case fromIntegral i of I# i -> LitI i
284 MachFloat f -> case fromRational f of F# f -> LitF f
285 MachDouble f -> case fromRational f of D# f -> LitD f
288 CharStr s i -> LitI (addr2Int# s)
291 -- sigh, a string in the heap is no good to us. We need a
292 -- static C pointer, since the type of a string literal is
293 -- Addr#. So, copy the string into C land and introduce a
294 -- memory leak at the same time.
296 case unsafePerformIO (do a <- mallocBytes (n+1);
297 strncpy a ba (fromIntegral n);
299 case a of { Ptr a -> return a })
300 of A# a -> LitI (addr2Int# a)
302 _ -> error "StgInterp.lit2expr: unhandled string constant type"
304 other -> pprPanic "lit2expr" (ppr lit)
306 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
310 -> mkVar ie (repOfId var) var
313 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
317 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
318 | repOfStgExpr scrut /= RepP
319 -> mkCasePrim (repOfStgExpr stgexpr)
320 bndr (stg2expr ie scrut)
324 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
325 | repOfStgExpr scrut == RepP
326 -> mkCaseAlg (repOfStgExpr stgexpr)
327 bndr (stg2expr ie scrut)
331 StgPrimApp op args res_ty
332 -> mkPrimOp (repOfStgExpr stgexpr)
333 op (map (arg2expr ie) args)
336 -> conapp2expr ie dcon args
338 StgLet binds@(StgNonRec v e) body
339 -> mkNonRec (repOfStgExpr stgexpr)
340 (head (translateBind ie binds))
341 (stg2expr (addOneToUniqSet ie v) body)
343 StgLet binds@(StgRec bs) body
344 -> mkRec (repOfStgExpr stgexpr)
345 (translateBind ie binds)
346 (stg2expr (addListToUniqSet ie (map fst bs)) body)
349 -> pprPanic "stg2expr" (ppr stgexpr)
352 = AltPrim (lit2expr lit) (stg2expr ie rhs)
353 doAlgAlt (dcon,vars,uses,rhs)
354 = AltAlg (dataConTag dcon - 1)
355 (map id2VaaRep (toHeapOrder vars))
356 (stg2expr (addListToUniqSet ie vars) rhs)
359 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
360 (rearranged,offsets) = unzip rearranged_w_offsets
364 def2expr StgNoDefault = Nothing
365 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
367 mkAppChain ie result_rep so_far []
369 mkAppChain ie result_rep so_far [a]
370 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
371 mkAppChain ie result_rep so_far (a:as)
372 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
374 mkCasePrim RepI = CasePrimI
375 mkCasePrim RepP = CasePrimP
377 mkCaseAlg RepI = CaseAlgI
378 mkCaseAlg RepP = CaseAlgP
380 -- any var that isn't in scope is turned into a Native
382 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
383 | otherwise = Native (toRdrName var)
387 mkNonRec RepI = NonRecI
388 mkNonRec RepP = NonRecP
390 mkPrimOp RepI = PrimOpI
391 mkPrimOp RepP = PrimOpP
393 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
394 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
395 arg2expr ie (StgLitArg lit) = lit2expr lit
396 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
398 repOfArg :: StgArg -> Rep
399 repOfArg (StgVarArg v) = repOfId v
400 repOfArg (StgLitArg lit) = repOfLit lit
401 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
403 id2VaaRep var = (var, repOfId var)
406 -- ---------------------------------------------------------------------------
407 -- Link interpretables into something we can run
408 -- ---------------------------------------------------------------------------
410 linkIModules :: ClosureEnv -- incoming global closure env; returned updated
411 -> ItblEnv -- incoming global itbl env; returned updated
412 -> [([UnlinkedIBind], ItblEnv)]
413 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
414 linkIModules gce gie mods = do
415 let (bindss, ies) = unzip mods
416 binds = concat bindss
417 top_level_binders = map (toRdrName.binder) binds
418 final_gie = foldr plusFM gie ies
421 new_gce = addListToFM gce (zip top_level_binders new_rhss)
422 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
423 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
424 new_binds = linkIBinds final_gie new_gce binds
426 return (new_binds, final_gie, new_gce)
429 -- We're supposed to augment the environments with the values of any
430 -- external functions/info tables we need as we go along, but that's a
431 -- lot of hassle so for now I'll look up external things as they crop
432 -- up and not cache them in the source symbol tables. The interpreted
433 -- code will still be referenced in the source symbol tables.
435 -- JRS 001025: above comment is probably out of date ... interpret
438 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
439 linkIBinds ie ce binds = map (linkIBind ie ce) binds
441 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
443 linkIExpr ie ce expr = case expr of
445 CaseAlgP bndr expr alts dflt ->
446 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
447 (linkDefault ie ce dflt)
449 CaseAlgI bndr expr alts dflt ->
450 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
451 (linkDefault ie ce dflt)
453 CasePrimP bndr expr alts dflt ->
454 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
455 (linkDefault ie ce dflt)
457 CasePrimI bndr expr alts dflt ->
458 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
459 (linkDefault ie ce dflt)
462 ConApp (lookupCon ie con)
465 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
468 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
470 ConAppPP con arg0 arg1 ->
471 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
473 ConAppPPP con arg0 arg1 arg2 ->
474 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
475 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
477 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
478 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
480 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
481 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
483 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
484 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
490 Native var -> lookupNative ce var
492 VarP v -> lookupVar ce VarP v
493 VarI v -> lookupVar ce VarI v
495 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
496 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
497 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
498 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
500 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
501 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
502 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
503 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
506 case lookupFM ie con of
507 Just (Ptr addr) -> addr
509 -- try looking up in the object files.
511 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
513 Nothing -> pprPanic "linkIExpr" (ppr con)
515 lookupNative ce var =
516 case lookupFM ce var of
519 -- try looking up in the object files.
520 let lbl = (rdrNameToCLabel var "closure")
521 addr = unsafePerformIO (lookupSymbol lbl) in
522 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
523 Just (A# addr) -> Native (unsafeCoerce# addr)
524 Nothing -> pprPanic "linkIExpr" (ppr var)
526 -- some VarI/VarP refer to top-level interpreted functions; we change
527 -- them into Natives here.
529 case lookupFM ce (toRdrName v) of
533 -- HACK!!! ToDo: cleaner
534 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
535 rdrNameToCLabel rn suffix =
536 _UNPK_(moduleNameFS (rdrNameModule rn))
537 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
539 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
540 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
542 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
543 linkPrimAlt ie ce (AltPrim lit rhs)
544 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
546 linkDefault ie ce Nothing = Nothing
547 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
549 -- ---------------------------------------------------------------------------
550 -- The interpreter proper
551 -- ---------------------------------------------------------------------------
553 -- The dynamic environment contains everything boxed.
554 -- eval* functions which look up values in it will know the
555 -- representation of the thing they are looking up, so they
556 -- can cast/unbox it as necessary.
558 -- ---------------------------------------------------------------------------
559 -- Evaluator for things of boxed (pointer) representation
560 -- ---------------------------------------------------------------------------
562 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
566 -- | trace ("evalP: " ++ showExprTag expr) False
567 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
568 = error "evalP: ?!?!"
571 evalP (Native p) de = unsafeCoerce# p
573 -- First try the dynamic env. If that fails, assume it's a top-level
574 -- binding and look in the static env. That gives an Expr, which we
575 -- must convert to a boxed thingy by applying evalP to it. Because
576 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
577 -- CAFs), it's always safe to use evalP.
579 = case lookupUFM de v of
581 Nothing -> error ("evalP: lookupUFM " ++ show v)
583 -- Deal with application of a function returning a pointer rep
584 -- to arguments of any persuasion. Note that the function itself
585 -- always has pointer rep.
586 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
587 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
588 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
589 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
591 -- Lambdas always return P-rep, but we need to do different things
592 -- depending on both the argument and result representations.
594 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
596 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
598 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
600 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
602 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
604 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
606 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
608 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
610 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
612 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
614 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
616 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
618 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
620 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
622 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
624 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
627 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
628 -- except in the sense that we go on and evaluate the body with whichever
629 -- evaluator was used for the expression as a whole.
630 evalP (NonRecP bind e) de
631 = evalP e (augment_nonrec bind de)
632 evalP (RecP binds b) de
633 = evalP b (augment_rec binds de)
634 evalP (CaseAlgP bndr expr alts def) de
635 = case helper_caseAlg bndr expr alts def de of
636 (rhs, de') -> evalP rhs de'
637 evalP (CasePrimP bndr expr alts def) de
638 = case helper_casePrim bndr expr alts def de of
639 (rhs, de') -> evalP rhs de'
642 -- ConApp can only be handled by evalP
643 evalP (ConApp itbl args) se de
646 -- This appalling hack suggested (gleefully) by SDM
647 -- It is not well typed (needless to say?)
648 loop :: [Expr] -> boxed
650 = trace "loop-empty" (
651 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
654 = trace "loop-not-empty" (
656 RepI -> case evalI a de of i# -> loop as i#
657 RepP -> let p = evalP a de in loop as p
661 evalP (ConAppI (A# itbl) a1) de
662 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
664 evalP (ConApp (A# itbl)) de
665 = mci_make_constr itbl
667 evalP (ConAppP (A# itbl) a1) de
668 = let p1 = evalP a1 de
669 in mci_make_constrP itbl p1
671 evalP (ConAppPP (A# itbl) a1 a2) de
672 = let p1 = evalP a1 de
674 in mci_make_constrPP itbl p1 p2
676 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
677 = let p1 = evalP a1 de
680 in mci_make_constrPPP itbl p1 p2 p3
685 = error ("evalP: unhandled case: " ++ showExprTag other)
687 --------------------------------------------------------
688 --- Evaluator for things of Int# representation
689 --------------------------------------------------------
691 -- Evaluate something which has an unboxed Int rep
692 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
695 -- | trace ("evalI: " ++ showExprTag expr) False
696 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
697 = error "evalI: ?!?!"
699 evalI (LitI i#) de = i#
702 case lookupUFM de v of
703 Just e -> case unsafeCoerce# e of I# i -> i
704 Nothing -> error ("evalI: lookupUFM " ++ show v)
706 -- Deal with application of a function returning an Int# rep
707 -- to arguments of any persuasion. Note that the function itself
708 -- always has pointer rep.
709 evalI (AppII e1 e2) de
710 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
711 evalI (AppPI e1 e2) de
712 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
713 evalI (AppFI e1 e2) de
714 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
715 evalI (AppDI e1 e2) de
716 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
718 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
719 -- except in the sense that we go on and evaluate the body with whichever
720 -- evaluator was used for the expression as a whole.
721 evalI (NonRecI bind b) de
722 = evalI b (augment_nonrec bind de)
723 evalI (RecI binds b) de
724 = evalI b (augment_rec binds de)
725 evalI (CaseAlgI bndr expr alts def) de
726 = case helper_caseAlg bndr expr alts def de of
727 (rhs, de') -> evalI rhs de'
728 evalI (CasePrimI bndr expr alts def) de
729 = case helper_casePrim bndr expr alts def de of
730 (rhs, de') -> evalI rhs de'
732 -- evalI can't be applied to a lambda term, by defn, since those
735 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
736 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
738 --evalI (NonRec (IBind v e) b) de
739 -- = evalI b (augment de v (eval e de))
742 = error ("evalI: unhandled case: " ++ showExprTag other)
744 --------------------------------------------------------
745 --- Evaluator for things of Float# representation
746 --------------------------------------------------------
748 -- Evaluate something which has an unboxed Int rep
749 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
752 -- | trace ("evalF: " ++ showExprTag expr) False
753 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
754 = error "evalF: ?!?!"
756 evalF (LitF f#) de = f#
759 case lookupUFM de v of
760 Just e -> case unsafeCoerce# e of F# i -> i
761 Nothing -> error ("evalF: lookupUFM " ++ show v)
763 -- Deal with application of a function returning an Int# rep
764 -- to arguments of any persuasion. Note that the function itself
765 -- always has pointer rep.
766 evalF (AppIF e1 e2) de
767 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
768 evalF (AppPF e1 e2) de
769 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
770 evalF (AppFF e1 e2) de
771 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
772 evalF (AppDF e1 e2) de
773 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
775 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
776 -- except in the sense that we go on and evaluate the body with whichever
777 -- evaluator was used for the expression as a whole.
778 evalF (NonRecF bind b) de
779 = evalF b (augment_nonrec bind de)
780 evalF (RecF binds b) de
781 = evalF b (augment_rec binds de)
782 evalF (CaseAlgF bndr expr alts def) de
783 = case helper_caseAlg bndr expr alts def de of
784 (rhs, de') -> evalF rhs de'
785 evalF (CasePrimF bndr expr alts def) de
786 = case helper_casePrim bndr expr alts def de of
787 (rhs, de') -> evalF rhs de'
789 -- evalF can't be applied to a lambda term, by defn, since those
792 evalF (PrimOpF op _) de
793 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
796 = error ("evalF: unhandled case: " ++ showExprTag other)
798 --------------------------------------------------------
799 --- Evaluator for things of Double# representation
800 --------------------------------------------------------
802 -- Evaluate something which has an unboxed Int rep
803 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
806 -- | trace ("evalD: " ++ showExprTag expr) False
807 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
808 = error "evalD: ?!?!"
810 evalD (LitD d#) de = d#
813 case lookupUFM de v of
814 Just e -> case unsafeCoerce# e of D# i -> i
815 Nothing -> error ("evalD: lookupUFM " ++ show v)
817 -- Deal with application of a function returning an Int# rep
818 -- to arguments of any persuasion. Note that the function itself
819 -- always has pointer rep.
820 evalD (AppID e1 e2) de
821 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
822 evalD (AppPD e1 e2) de
823 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
824 evalD (AppFD e1 e2) de
825 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
826 evalD (AppDD e1 e2) de
827 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
829 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
830 -- except in the sense that we go on and evaluate the body with whichever
831 -- evaluator was used for the expression as a whole.
832 evalD (NonRecD bind b) de
833 = evalD b (augment_nonrec bind de)
834 evalD (RecD binds b) de
835 = evalD b (augment_rec binds de)
836 evalD (CaseAlgD bndr expr alts def) de
837 = case helper_caseAlg bndr expr alts def de of
838 (rhs, de') -> evalD rhs de'
839 evalD (CasePrimD bndr expr alts def) de
840 = case helper_casePrim bndr expr alts def de of
841 (rhs, de') -> evalD rhs de'
843 -- evalD can't be applied to a lambda term, by defn, since those
846 evalD (PrimOpD op _) de
847 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
850 = error ("evalD: unhandled case: " ++ showExprTag other)
852 --------------------------------------------------------
853 --- Helper bits and pieces
854 --------------------------------------------------------
856 -- Find the Rep of any Expr
857 repOf :: LinkedIExpr -> Rep
859 repOf (LamPP _ _) = RepP
860 repOf (LamPI _ _) = RepP
861 repOf (LamPF _ _) = RepP
862 repOf (LamPD _ _) = RepP
863 repOf (LamIP _ _) = RepP
864 repOf (LamII _ _) = RepP
865 repOf (LamIF _ _) = RepP
866 repOf (LamID _ _) = RepP
867 repOf (LamFP _ _) = RepP
868 repOf (LamFI _ _) = RepP
869 repOf (LamFF _ _) = RepP
870 repOf (LamFD _ _) = RepP
871 repOf (LamDP _ _) = RepP
872 repOf (LamDI _ _) = RepP
873 repOf (LamDF _ _) = RepP
874 repOf (LamDD _ _) = RepP
876 repOf (AppPP _ _) = RepP
877 repOf (AppPI _ _) = RepI
878 repOf (AppPF _ _) = RepF
879 repOf (AppPD _ _) = RepD
880 repOf (AppIP _ _) = RepP
881 repOf (AppII _ _) = RepI
882 repOf (AppIF _ _) = RepF
883 repOf (AppID _ _) = RepD
884 repOf (AppFP _ _) = RepP
885 repOf (AppFI _ _) = RepI
886 repOf (AppFF _ _) = RepF
887 repOf (AppFD _ _) = RepD
888 repOf (AppDP _ _) = RepP
889 repOf (AppDI _ _) = RepI
890 repOf (AppDF _ _) = RepF
891 repOf (AppDD _ _) = RepD
893 repOf (NonRecP _ _) = RepP
894 repOf (NonRecI _ _) = RepI
895 repOf (NonRecF _ _) = RepF
896 repOf (NonRecD _ _) = RepD
898 repOf (LitI _) = RepI
899 repOf (LitF _) = RepF
900 repOf (LitD _) = RepD
902 repOf (VarP _) = RepI
903 repOf (VarI _) = RepI
904 repOf (VarF _) = RepF
905 repOf (VarD _) = RepD
907 repOf (PrimOpP _ _) = RepP
908 repOf (PrimOpI _ _) = RepI
909 repOf (PrimOpF _ _) = RepF
910 repOf (PrimOpD _ _) = RepD
912 repOf (ConApp _) = RepP
913 repOf (ConAppI _ _) = RepP
914 repOf (ConAppP _ _) = RepP
915 repOf (ConAppPP _ _ _) = RepP
916 repOf (ConAppPPP _ _ _ _) = RepP
918 repOf (CaseAlgP _ _ _ _) = RepP
919 repOf (CaseAlgI _ _ _ _) = RepI
920 repOf (CaseAlgF _ _ _ _) = RepF
921 repOf (CaseAlgD _ _ _ _) = RepD
923 repOf (CasePrimP _ _ _ _) = RepP
924 repOf (CasePrimI _ _ _ _) = RepI
925 repOf (CasePrimF _ _ _ _) = RepF
926 repOf (CasePrimD _ _ _ _) = RepD
929 = error ("repOf: unhandled case: " ++ showExprTag other)
931 -- how big (in words) is one of these
932 repSizeW :: Rep -> Int
937 -- Evaluate an expression, using the appropriate evaluator,
938 -- then box up the result. Note that it's only safe to use this
939 -- to create values to put in the environment. You can't use it
940 -- to create a value which might get passed to native code since that
941 -- code will have no idea that unboxed things have been boxed.
942 eval :: LinkedIExpr -> UniqFM boxed -> boxed
945 RepI -> unsafeCoerce# (I# (evalI expr de))
946 RepP -> evalP expr de
947 RepF -> unsafeCoerce# (F# (evalF expr de))
948 RepD -> unsafeCoerce# (D# (evalD expr de))
950 -- Evaluate the scrutinee of a case, select an alternative,
951 -- augment the environment appropriately, and return the alt
952 -- and the augmented environment.
953 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
955 -> (LinkedIExpr, UniqFM boxed)
956 helper_caseAlg bndr expr alts def de
957 = let exprEv = evalP expr de
959 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
960 case select_altAlg (tagOf exprEv) alts def of
961 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
964 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
966 -> (LinkedIExpr, UniqFM boxed)
967 helper_casePrim bndr expr alts def de
969 -- Umm, can expr have any other rep? Yes ...
970 -- CharRep, DoubleRep, FloatRep. What about string reps?
971 RepI -> case evalI expr de of
972 i# -> (select_altPrim alts def (LitI i#),
973 addToUFM de bndr (unsafeCoerce# (I# i#)))
976 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
977 augment_from_constr de con ([],offset)
979 augment_from_constr de con ((v,rep):vs,offset)
982 RepP -> indexPtrOffClosure con offset
983 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
985 augment_from_constr (addToUFM de v v_binding) con
986 (vs,offset + repSizeW rep)
988 -- Augment the environment for a non-recursive let.
989 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
990 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
992 -- Augment the environment for a recursive let.
993 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
995 = let vars = map binder binds
996 rhss = map bindee binds
997 rhs_vs = map (\rhs -> eval rhs de') rhss
998 de' = addListToUFM de (zip vars rhs_vs)
1002 -- a must be a constructor?
1004 tagOf x = I# (dataToTag# x)
1006 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1007 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1008 select_altAlg tag [] (Just def) = ([],def)
1009 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1012 else select_altAlg tag alts def
1014 -- literal may only be a literal, not an arbitrary expression
1015 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1016 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1017 select_altPrim [] (Just def) literal = def
1018 select_altPrim ((AltPrim lit rhs):alts) def literal
1019 = if eqLits lit literal
1021 else select_altPrim alts def literal
1023 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1026 -- a is a constructor
1027 indexPtrOffClosure :: a -> Int -> b
1028 indexPtrOffClosure con (I# offset)
1029 = case indexPtrOffClosure# con offset of (# x #) -> x
1031 indexIntOffClosure :: a -> Int -> Int#
1032 indexIntOffClosure con (I# offset)
1033 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1036 ------------------------------------------------------------------------
1037 --- Manufacturing of info tables for DataCons defined in this module ---
1038 ------------------------------------------------------------------------
1040 #if __GLASGOW_HASKELL__ <= 408
1043 type ItblPtr = Ptr StgInfoTable
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,ItblPtr)
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)
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, addr `plusPtr` 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) (castPtr 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 (castPtr 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 -> Ptr a -> IO (Ptr b)
1219 store x addr = do poke addr x
1220 return (castPtr (addr `plusPtr` sizeOf x))
1222 load :: Storable a => Ptr a -> IO (Ptr b, a)
1223 load addr = do x <- peek addr
1224 return (castPtr (addr `plusPtr` sizeOf x), x)
1226 -----------------------------------------------------------------------------q
1228 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()