2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
11 linkIModules, -- :: ItblEnv -> ClosureEnv -> [[UnlinkedIBind]] ->
12 -- ([LinkedIBind], ItblEnv, ClosureEnv)
14 runStgI -- tmp, for testing
17 {- -----------------------------------------------------------------------------
20 - link should be in the IO monad, so it can modify the symtabs as it
23 - need a way to remove the bindings for a module from the symtabs.
24 maybe the symtabs should be indexed by module first.
26 - change the representation to something less verbose (?).
28 - converting string literals to Addr# is horrible and introduces
29 a memory leak. See if something can be done about this.
31 ----------------------------------------------------------------------------- -}
33 #include "HsVersions.h"
37 import Id ( Id, idPrimRep )
40 import PrimOp ( PrimOp(..) )
41 import PrimRep ( PrimRep(..) )
42 import Literal ( Literal(..) )
43 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
44 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
45 import ClosureInfo ( mkVirtHeapOffsets )
46 import Name ( toRdrName )
50 import {-# SOURCE #-} MCI_make_constr
52 import IOExts ( unsafePerformIO ) -- ToDo: remove
53 import PrelGHC --( unsafeCoerce#, dataToTag#,
54 -- indexPtrOffClosure#, indexWordOffClosure# )
55 import IO ( hPutStr, stderr )
57 import PrelAddr ( Addr(..) )
58 import PrelFloat ( Float(..), Double(..) )
64 import GlaExts ( Int(..) )
65 import Module ( moduleNameFS )
68 import TyCon ( TyCon )
69 import Class ( Class )
73 import RdrName ( RdrName )
75 import Panic ( panic )
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 -- ---------------------------------------------------------------------------
88 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
91 runStgI = panic "StgInterp.runStgI: not implemented"
92 linkIModules = panic "StgInterp.linkIModules: not implemented"
95 -- the bindings need to have a binding for stgMain, and the
96 -- body of it had better represent something of type Int# -> Int#
97 runStgI tycons classes stgbinds
99 let unlinked_binds = concatMap (stg2IBinds emptyUniqSet) stgbinds
103 = "-------------------- Unlinked Binds --------------------\n"
104 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
107 hPutStr stderr dbg_txt
109 (linked_binds, ie, ce) <-
110 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
113 = "-------------------- Linked Binds --------------------\n"
114 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
117 hPutStr stderr dbg_txt
120 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
122 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
125 = I# (evalI (AppII stgMain (LitI 0#))
126 emptyUFM{-initial de-}
130 -- ---------------------------------------------------------------------------
131 -- Convert STG to an unlinked interpretable
132 -- ---------------------------------------------------------------------------
134 stg2IBinds :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
135 stg2IBinds ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
136 stg2IBinds ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
137 where ie' = addListToUniqSet ie (map fst vs_n_es)
139 isRec (StgNonRec _ _) = False
140 isRec (StgRec _) = True
142 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
143 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
146 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
147 rhsRep = repOfStgExpr rhs
148 mkLambdas [] = rhsExpr
149 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
150 rhs2expr ie (StgRhsCon ccs dcon args)
151 = conapp2expr ie dcon args
153 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
154 conapp2expr ie dcon args
155 = mkConApp con_rdrname reps exprs
157 con_rdrname = toRdrName dcon
158 exprs = map (arg2expr ie) inHeapOrder
159 reps = map repOfArg inHeapOrder
160 inHeapOrder = toHeapOrder args
162 toHeapOrder :: [StgArg] -> [StgArg]
164 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
165 (rearranged, offsets) = unzip rearranged_w_offsets
169 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
171 -- Handle most common cases specially; do the rest with a generic
172 -- mechanism (deferred till later :)
173 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
174 mkConApp nm [] [] = ConApp nm
175 mkConApp nm [RepI] [a1] = ConAppI nm a1
176 mkConApp nm [RepP] [a1] = ConAppP nm a1
177 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
178 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
179 mkConApp nm reps args
180 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
182 mkLam RepP RepP = LamPP
183 mkLam RepI RepP = LamIP
184 mkLam RepP RepI = LamPI
185 mkLam RepI RepI = LamII
186 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
188 mkApp RepP RepP = AppPP
189 mkApp RepI RepP = AppIP
190 mkApp RepP RepI = AppPI
191 mkApp RepI RepI = AppII
192 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
195 repOfId = primRep2Rep . idPrimRep
200 -- genuine lifted types
203 -- all these are unboxed, fit into a word, and we assume they
204 -- all have the same call/return convention.
212 -- these are pretty dodgy: really pointers, but
213 -- we can't let the compiler build thunks with these reps.
214 ForeignObjRep -> RepP
215 StableNameRep -> RepP
220 other -> pprPanic "primRep2Rep" (ppr other)
222 repOfStgExpr :: StgExpr -> Rep
227 StgCase scrut live liveR bndr srt alts
228 -> case altRhss alts of
229 (a:_) -> repOfStgExpr a
230 [] -> panic "repOfStgExpr: no alts"
234 -> repOfApp ((deNoteType.repType.idType) var) (length args)
236 StgPrimApp op args res_ty
237 -> (primRep2Rep.typePrimRep) res_ty
239 StgLet binds body -> repOfStgExpr body
240 StgLetNoEscape live liveR binds body -> repOfStgExpr body
242 StgConApp con args -> RepP -- by definition
245 -> pprPanic "repOfStgExpr" (ppr other)
247 altRhss (StgAlgAlts ty alts def)
248 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
249 altRhss (StgPrimAlts ty alts def)
250 = [rhs | (lit,rhs) <- alts] ++ defRhs def
253 defRhs (StgBindDefault rhs)
256 -- returns the Rep of the result of applying ty to n args.
257 repOfApp :: Type -> Int -> Rep
258 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
259 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
271 MachStr _ -> RepI -- because it's a ptr outside the heap
272 other -> pprPanic "repOfLit" (ppr lit)
274 lit2expr :: Literal -> UnlinkedIExpr
277 MachInt i -> case fromIntegral i of I# i -> LitI i
278 MachWord i -> case fromIntegral i of I# i -> LitI i
279 MachAddr i -> case fromIntegral i of I# i -> LitI i
280 MachChar i -> case fromIntegral i of I# i -> LitI i
281 MachFloat f -> case fromRational f of F# f -> LitF f
282 MachDouble f -> case fromRational f of D# f -> LitD f
285 CharStr s i -> LitI (addr2Int# s)
288 -- sigh, a string in the heap is no good to us. We need a
289 -- static C pointer, since the type of a string literal is
290 -- Addr#. So, copy the string into C land and introduce a
291 -- memory leak at the same time.
293 case unsafePerformIO (do a <- malloc (n+1);
294 strncpy a ba (fromIntegral n);
295 writeCharOffAddr a n '\0'
297 of A# a -> LitI (addr2Int# a)
299 _ -> error "StgInterp.lit2expr: unhandled string constant type"
301 other -> pprPanic "lit2expr" (ppr lit)
303 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
307 -> mkVar ie (repOfId var) var
310 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
314 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
315 | repOfStgExpr scrut /= RepP
316 -> mkCasePrim (repOfStgExpr stgexpr)
317 bndr (stg2expr ie scrut)
321 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
322 | repOfStgExpr scrut == RepP
323 -> mkCaseAlg (repOfStgExpr stgexpr)
324 bndr (stg2expr ie scrut)
328 StgPrimApp op args res_ty
329 -> mkPrimOp (repOfStgExpr stgexpr)
330 op (map (arg2expr ie) args)
333 -> conapp2expr ie dcon args
335 StgLet binds@(StgNonRec v e) body
336 -> mkNonRec (repOfStgExpr stgexpr)
337 (head (stg2IBinds ie binds))
338 (stg2expr (addOneToUniqSet ie v) body)
340 StgLet binds@(StgRec bs) body
341 -> mkRec (repOfStgExpr stgexpr)
342 (stg2IBinds ie binds)
343 (stg2expr (addListToUniqSet ie (map fst bs)) body)
346 -> pprPanic "stg2expr" (ppr stgexpr)
349 = AltPrim (lit2expr lit) (stg2expr ie rhs)
350 doAlgAlt (dcon,vars,uses,rhs)
351 = AltAlg (dataConTag dcon - 1)
352 (map id2VaaRep (toHeapOrder vars))
353 (stg2expr (addListToUniqSet ie vars) rhs)
356 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
357 (rearranged,offsets) = unzip rearranged_w_offsets
361 def2expr StgNoDefault = Nothing
362 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
364 mkAppChain ie result_rep so_far []
366 mkAppChain ie result_rep so_far [a]
367 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
368 mkAppChain ie result_rep so_far (a:as)
369 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
371 mkCasePrim RepI = CasePrimI
372 mkCasePrim RepP = CasePrimP
374 mkCaseAlg RepI = CaseAlgI
375 mkCaseAlg RepP = CaseAlgP
377 -- any var that isn't in scope is turned into a Native
379 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
380 | otherwise = Native (toRdrName var)
384 mkNonRec RepI = NonRecI
385 mkNonRec RepP = NonRecP
387 mkPrimOp RepI = PrimOpI
388 mkPrimOp RepP = PrimOpP
390 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
391 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
392 arg2expr ie (StgLitArg lit) = lit2expr lit
393 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
395 repOfArg :: StgArg -> Rep
396 repOfArg (StgVarArg v) = repOfId v
397 repOfArg (StgLitArg lit) = repOfLit lit
398 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
400 id2VaaRep var = (var, repOfId var)
402 -- ---------------------------------------------------------------------------
403 -- Link an interpretable into something we can run
404 -- ---------------------------------------------------------------------------
406 linkIModules :: ItblEnv -> ClosureEnv -> [([TyCon],[UnlinkedIBind])] ->
407 IO ([LinkedIBind], ItblEnv, ClosureEnv)
408 linkIModules ie ce mods = do
409 let (tyconss, bindss) = unzip mods
410 tycons = concat tyconss
411 binds = concat bindss
412 top_level_binders = map (toRdrName.binder) binds
414 new_ie <- mkITbls (concat tyconss)
415 let new_ce = addListToFM ce (zip top_level_binders new_rhss)
416 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
417 ---vvvvvvvvv--------------------------------------^^^^^^^^^-- circular
418 (new_binds, final_ie, final_ce) = linkIBinds new_ie new_ce binds
420 return (new_binds, final_ie, final_ce)
422 -- We're supposed to augment the environments with the values of any
423 -- external functions/info tables we need as we go along, but that's a
424 -- lot of hassle so for now I'll look up external things as they crop
425 -- up and not cache them in the source symbol tables. The interpreted
426 -- code will still be referenced in the source symbol tables.
429 -- Make info tables for the data decls in this module
430 mkITbls :: [TyCon] -> IO ItblEnv
431 mkITbls [] = return emptyFM
432 mkITbls (tc:tcs) = do itbls <- mkITbl tc
433 itbls2 <- mkITbls tcs
434 return (itbls `plusFM` itbls2)
436 mkITbl :: TyCon -> IO ItblEnv
438 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
440 | not (isDataTyCon tc)
442 | n == length dcs -- paranoia; this is an assertion.
443 = make_constr_itbls dcs
445 dcs = tyConDataCons tc
446 n = tyConFamilySize tc
449 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] ->
450 ([LinkedIBind], ItblEnv, ClosureEnv)
451 linkIBinds ie ce binds
452 = (new_binds, ie, ce)
453 where new_binds = map (linkIBind ie ce) binds
455 linkIBinds' ie ce binds
456 = new_binds where (new_binds, ie, ce) = linkIBinds ie ce binds
458 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
460 linkIExpr ie ce expr = case expr of
462 CaseAlgP bndr expr alts dflt ->
463 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
464 (linkDefault ie ce dflt)
466 CaseAlgI bndr expr alts dflt ->
467 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
468 (linkDefault ie ce dflt)
470 CasePrimP bndr expr alts dflt ->
471 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
472 (linkDefault ie ce dflt)
474 CasePrimI bndr expr alts dflt ->
475 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
476 (linkDefault ie ce dflt)
479 ConApp (lookupCon ie con)
482 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
485 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
487 ConAppPP con arg0 arg1 ->
488 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
490 ConAppPPP con arg0 arg1 arg2 ->
491 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
492 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
494 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
495 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
497 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
498 RecP binds expr -> RecP (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
500 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
501 RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
507 Native var -> lookupNative ce var
509 VarP v -> lookupVar ce VarP v
510 VarI v -> lookupVar ce VarI v
512 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
513 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
514 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
515 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
517 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
518 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
519 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
520 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
523 case lookupFM ie con of
526 -- try looking up in the object files.
528 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
530 Nothing -> pprPanic "linkIExpr" (ppr con)
532 lookupNative ce var =
533 case lookupFM ce var of
536 -- try looking up in the object files.
537 let lbl = (rdrNameToCLabel var "closure")
538 addr = unsafePerformIO (lookupSymbol lbl) in
539 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
540 Just (A# addr) -> Native (unsafeCoerce# addr)
541 Nothing -> pprPanic "linkIExpr" (ppr var)
543 -- some VarI/VarP refer to top-level interpreted functions; we change
544 -- them into Natives here.
546 case lookupFM ce (toRdrName v) of
550 -- HACK!!! ToDo: cleaner
551 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
552 rdrNameToCLabel rn suffix =
553 _UNPK_(moduleNameFS (rdrNameModule rn))
554 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
556 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
557 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
559 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
560 linkPrimAlt ie ce (AltPrim lit rhs)
561 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
563 linkDefault ie ce Nothing = Nothing
564 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
566 -- ---------------------------------------------------------------------------
567 -- The interpreter proper
568 -- ---------------------------------------------------------------------------
570 -- The dynamic environment contains everything boxed.
571 -- eval* functions which look up values in it will know the
572 -- representation of the thing they are looking up, so they
573 -- can cast/unbox it as necessary.
575 -- ---------------------------------------------------------------------------
576 -- Evaluator for things of boxed (pointer) representation
577 -- ---------------------------------------------------------------------------
579 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
583 -- | trace ("evalP: " ++ showExprTag expr) False
584 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
585 = error "evalP: ?!?!"
588 evalP (Native p) de = unsafeCoerce# p
590 -- First try the dynamic env. If that fails, assume it's a top-level
591 -- binding and look in the static env. That gives an Expr, which we
592 -- must convert to a boxed thingy by applying evalP to it. Because
593 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
594 -- CAFs), it's always safe to use evalP.
596 = case lookupUFM de v of
598 Nothing -> error ("evalP: lookupUFM " ++ show v)
600 -- Deal with application of a function returning a pointer rep
601 -- to arguments of any persuasion. Note that the function itself
602 -- always has pointer rep.
603 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
604 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
605 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
606 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
608 -- Lambdas always return P-rep, but we need to do different things
609 -- depending on both the argument and result representations.
611 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
613 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
615 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
617 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
619 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
621 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
623 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
625 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
627 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
629 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
631 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
633 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
635 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
637 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
639 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
641 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
644 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
645 -- except in the sense that we go on and evaluate the body with whichever
646 -- evaluator was used for the expression as a whole.
647 evalP (NonRecP bind e) de
648 = evalP e (augment_nonrec bind de)
649 evalP (RecP binds b) de
650 = evalP b (augment_rec binds de)
651 evalP (CaseAlgP bndr expr alts def) de
652 = case helper_caseAlg bndr expr alts def de of
653 (rhs, de') -> evalP rhs de'
654 evalP (CasePrimP bndr expr alts def) de
655 = case helper_casePrim bndr expr alts def de of
656 (rhs, de') -> evalP rhs de'
659 -- ConApp can only be handled by evalP
660 evalP (ConApp itbl args) se de
663 -- This appalling hack suggested (gleefully) by SDM
664 -- It is not well typed (needless to say?)
665 loop :: [Expr] -> boxed
667 = trace "loop-empty" (
668 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
671 = trace "loop-not-empty" (
673 RepI -> case evalI a de of i# -> loop as i#
674 RepP -> let p = evalP a de in loop as p
678 evalP (ConAppI (A# itbl) a1) de
679 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
681 evalP (ConApp (A# itbl)) de
682 = mci_make_constr itbl
684 evalP (ConAppP (A# itbl) a1) de
685 = let p1 = evalP a1 de
686 in mci_make_constrP itbl p1
688 evalP (ConAppPP (A# itbl) a1 a2) de
689 = let p1 = evalP a1 de
691 in mci_make_constrPP itbl p1 p2
693 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
694 = let p1 = evalP a1 de
697 in mci_make_constrPPP itbl p1 p2 p3
702 = error ("evalP: unhandled case: " ++ showExprTag other)
704 --------------------------------------------------------
705 --- Evaluator for things of Int# representation
706 --------------------------------------------------------
708 -- Evaluate something which has an unboxed Int rep
709 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
712 -- | trace ("evalI: " ++ showExprTag expr) False
713 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
714 = error "evalI: ?!?!"
716 evalI (LitI i#) de = i#
719 case lookupUFM de v of
720 Just e -> case unsafeCoerce# e of I# i -> i
721 Nothing -> error ("evalI: lookupUFM " ++ show v)
723 -- Deal with application of a function returning an Int# rep
724 -- to arguments of any persuasion. Note that the function itself
725 -- always has pointer rep.
726 evalI (AppII e1 e2) de
727 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
728 evalI (AppPI e1 e2) de
729 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
730 evalI (AppFI e1 e2) de
731 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
732 evalI (AppDI e1 e2) de
733 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
735 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
736 -- except in the sense that we go on and evaluate the body with whichever
737 -- evaluator was used for the expression as a whole.
738 evalI (NonRecI bind b) de
739 = evalI b (augment_nonrec bind de)
740 evalI (RecI binds b) de
741 = evalI b (augment_rec binds de)
742 evalI (CaseAlgI bndr expr alts def) de
743 = case helper_caseAlg bndr expr alts def de of
744 (rhs, de') -> evalI rhs de'
745 evalI (CasePrimI bndr expr alts def) de
746 = case helper_casePrim bndr expr alts def de of
747 (rhs, de') -> evalI rhs de'
749 -- evalI can't be applied to a lambda term, by defn, since those
752 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
753 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
755 --evalI (NonRec (IBind v e) b) de
756 -- = evalI b (augment de v (eval e de))
759 = error ("evalI: unhandled case: " ++ showExprTag other)
761 --------------------------------------------------------
762 --- Evaluator for things of Float# representation
763 --------------------------------------------------------
765 -- Evaluate something which has an unboxed Int rep
766 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
769 -- | trace ("evalF: " ++ showExprTag expr) False
770 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
771 = error "evalF: ?!?!"
773 evalF (LitF f#) de = f#
776 case lookupUFM de v of
777 Just e -> case unsafeCoerce# e of F# i -> i
778 Nothing -> error ("evalF: lookupUFM " ++ show v)
780 -- Deal with application of a function returning an Int# rep
781 -- to arguments of any persuasion. Note that the function itself
782 -- always has pointer rep.
783 evalF (AppIF e1 e2) de
784 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
785 evalF (AppPF e1 e2) de
786 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
787 evalF (AppFF e1 e2) de
788 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
789 evalF (AppDF e1 e2) de
790 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
792 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
793 -- except in the sense that we go on and evaluate the body with whichever
794 -- evaluator was used for the expression as a whole.
795 evalF (NonRecF bind b) de
796 = evalF b (augment_nonrec bind de)
797 evalF (RecF binds b) de
798 = evalF b (augment_rec binds de)
799 evalF (CaseAlgF bndr expr alts def) de
800 = case helper_caseAlg bndr expr alts def de of
801 (rhs, de') -> evalF rhs de'
802 evalF (CasePrimF bndr expr alts def) de
803 = case helper_casePrim bndr expr alts def de of
804 (rhs, de') -> evalF rhs de'
806 -- evalF can't be applied to a lambda term, by defn, since those
809 evalF (PrimOpF op _) de
810 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
813 = error ("evalF: unhandled case: " ++ showExprTag other)
815 --------------------------------------------------------
816 --- Evaluator for things of Double# representation
817 --------------------------------------------------------
819 -- Evaluate something which has an unboxed Int rep
820 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
823 -- | trace ("evalD: " ++ showExprTag expr) False
824 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
825 = error "evalD: ?!?!"
827 evalD (LitD d#) de = d#
830 case lookupUFM de v of
831 Just e -> case unsafeCoerce# e of D# i -> i
832 Nothing -> error ("evalD: lookupUFM " ++ show v)
834 -- Deal with application of a function returning an Int# rep
835 -- to arguments of any persuasion. Note that the function itself
836 -- always has pointer rep.
837 evalD (AppID e1 e2) de
838 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
839 evalD (AppPD e1 e2) de
840 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
841 evalD (AppFD e1 e2) de
842 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
843 evalD (AppDD e1 e2) de
844 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
846 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
847 -- except in the sense that we go on and evaluate the body with whichever
848 -- evaluator was used for the expression as a whole.
849 evalD (NonRecD bind b) de
850 = evalD b (augment_nonrec bind de)
851 evalD (RecD binds b) de
852 = evalD b (augment_rec binds de)
853 evalD (CaseAlgD bndr expr alts def) de
854 = case helper_caseAlg bndr expr alts def de of
855 (rhs, de') -> evalD rhs de'
856 evalD (CasePrimD bndr expr alts def) de
857 = case helper_casePrim bndr expr alts def de of
858 (rhs, de') -> evalD rhs de'
860 -- evalD can't be applied to a lambda term, by defn, since those
863 evalD (PrimOpD op _) de
864 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
867 = error ("evalD: unhandled case: " ++ showExprTag other)
869 --------------------------------------------------------
870 --- Helper bits and pieces
871 --------------------------------------------------------
873 -- Find the Rep of any Expr
874 repOf :: LinkedIExpr -> Rep
876 repOf (LamPP _ _) = RepP
877 repOf (LamPI _ _) = RepP
878 repOf (LamPF _ _) = RepP
879 repOf (LamPD _ _) = RepP
880 repOf (LamIP _ _) = RepP
881 repOf (LamII _ _) = RepP
882 repOf (LamIF _ _) = RepP
883 repOf (LamID _ _) = RepP
884 repOf (LamFP _ _) = RepP
885 repOf (LamFI _ _) = RepP
886 repOf (LamFF _ _) = RepP
887 repOf (LamFD _ _) = RepP
888 repOf (LamDP _ _) = RepP
889 repOf (LamDI _ _) = RepP
890 repOf (LamDF _ _) = RepP
891 repOf (LamDD _ _) = RepP
893 repOf (AppPP _ _) = RepP
894 repOf (AppPI _ _) = RepI
895 repOf (AppPF _ _) = RepF
896 repOf (AppPD _ _) = RepD
897 repOf (AppIP _ _) = RepP
898 repOf (AppII _ _) = RepI
899 repOf (AppIF _ _) = RepF
900 repOf (AppID _ _) = RepD
901 repOf (AppFP _ _) = RepP
902 repOf (AppFI _ _) = RepI
903 repOf (AppFF _ _) = RepF
904 repOf (AppFD _ _) = RepD
905 repOf (AppDP _ _) = RepP
906 repOf (AppDI _ _) = RepI
907 repOf (AppDF _ _) = RepF
908 repOf (AppDD _ _) = RepD
910 repOf (NonRecP _ _) = RepP
911 repOf (NonRecI _ _) = RepI
912 repOf (NonRecF _ _) = RepF
913 repOf (NonRecD _ _) = RepD
915 repOf (LitI _) = RepI
916 repOf (LitF _) = RepF
917 repOf (LitD _) = RepD
919 repOf (VarP _) = RepI
920 repOf (VarI _) = RepI
921 repOf (VarF _) = RepF
922 repOf (VarD _) = RepD
924 repOf (PrimOpP _ _) = RepP
925 repOf (PrimOpI _ _) = RepI
926 repOf (PrimOpF _ _) = RepF
927 repOf (PrimOpD _ _) = RepD
929 repOf (ConApp _) = RepP
930 repOf (ConAppI _ _) = RepP
931 repOf (ConAppP _ _) = RepP
932 repOf (ConAppPP _ _ _) = RepP
933 repOf (ConAppPPP _ _ _ _) = RepP
935 repOf (CaseAlgP _ _ _ _) = RepP
936 repOf (CaseAlgI _ _ _ _) = RepI
937 repOf (CaseAlgF _ _ _ _) = RepF
938 repOf (CaseAlgD _ _ _ _) = RepD
940 repOf (CasePrimP _ _ _ _) = RepP
941 repOf (CasePrimI _ _ _ _) = RepI
942 repOf (CasePrimF _ _ _ _) = RepF
943 repOf (CasePrimD _ _ _ _) = RepD
946 = error ("repOf: unhandled case: " ++ showExprTag other)
948 -- how big (in words) is one of these
949 repSizeW :: Rep -> Int
954 -- Evaluate an expression, using the appropriate evaluator,
955 -- then box up the result. Note that it's only safe to use this
956 -- to create values to put in the environment. You can't use it
957 -- to create a value which might get passed to native code since that
958 -- code will have no idea that unboxed things have been boxed.
959 eval :: LinkedIExpr -> UniqFM boxed -> boxed
962 RepI -> unsafeCoerce# (I# (evalI expr de))
963 RepP -> evalP expr de
964 RepF -> unsafeCoerce# (F# (evalF expr de))
965 RepD -> unsafeCoerce# (D# (evalD expr de))
967 -- Evaluate the scrutinee of a case, select an alternative,
968 -- augment the environment appropriately, and return the alt
969 -- and the augmented environment.
970 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
972 -> (LinkedIExpr, UniqFM boxed)
973 helper_caseAlg bndr expr alts def de
974 = let exprEv = evalP expr de
976 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
977 case select_altAlg (tagOf exprEv) alts def of
978 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
981 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
983 -> (LinkedIExpr, UniqFM boxed)
984 helper_casePrim bndr expr alts def de
986 -- Umm, can expr have any other rep? Yes ...
987 -- CharRep, DoubleRep, FloatRep. What about string reps?
988 RepI -> case evalI expr de of
989 i# -> (select_altPrim alts def (LitI i#),
990 addToUFM de bndr (unsafeCoerce# (I# i#)))
993 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
994 augment_from_constr de con ([],offset)
996 augment_from_constr de con ((v,rep):vs,offset)
999 RepP -> indexPtrOffClosure con offset
1000 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1002 augment_from_constr (addToUFM de v v_binding) con
1003 (vs,offset + repSizeW rep)
1005 -- Augment the environment for a non-recursive let.
1006 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1007 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1009 -- Augment the environment for a recursive let.
1010 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1011 augment_rec binds de
1012 = let vars = map binder binds
1013 rhss = map bindee binds
1014 rhs_vs = map (\rhs -> eval rhs de') rhss
1015 de' = addListToUFM de (zip vars rhs_vs)
1019 -- a must be a constructor?
1021 tagOf x = I# (dataToTag# x)
1023 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1024 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1025 select_altAlg tag [] (Just def) = ([],def)
1026 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1029 else select_altAlg tag alts def
1031 -- literal may only be a literal, not an arbitrary expression
1032 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1033 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1034 select_altPrim [] (Just def) literal = def
1035 select_altPrim ((AltPrim lit rhs):alts) def literal
1036 = if eqLits lit literal
1038 else select_altPrim alts def literal
1040 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1043 -- a is a constructor
1044 indexPtrOffClosure :: a -> Int -> b
1045 indexPtrOffClosure con (I# offset)
1046 = case indexPtrOffClosure# con offset of (# x #) -> x
1048 indexIntOffClosure :: a -> Int -> Int#
1049 indexIntOffClosure con (I# offset)
1050 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1053 ------------------------------------------------------------------------
1054 --- Manufacturing of info tables for DataCons defined in this module ---
1055 ------------------------------------------------------------------------
1058 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1060 -- Assumes constructors are numbered from zero, not one
1061 make_constr_itbls :: [DataCon] -> IO ItblEnv
1062 make_constr_itbls cons
1064 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1065 return (listToFM is)
1067 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1068 return (listToFM is)
1070 mk_vecret_itbl (dcon, conNo)
1071 = mk_itbl dcon conNo (vecret_entry conNo)
1072 mk_dirret_itbl (dcon, conNo)
1073 = mk_itbl dcon conNo mci_constr_entry
1075 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1076 mk_itbl dcon conNo entry_addr
1077 = let (tot_wds, ptr_wds, _)
1078 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1080 nptrs = tot_wds - ptr_wds
1081 itbl = StgInfoTable {
1082 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1083 tipe = fromIntegral cONSTR,
1084 srtlen = fromIntegral conNo,
1085 code0 = fromIntegral code0, code1 = fromIntegral code1,
1086 code2 = fromIntegral code2, code3 = fromIntegral code3,
1087 code4 = fromIntegral code4, code5 = fromIntegral code5,
1088 code6 = fromIntegral code6, code7 = fromIntegral code7
1090 -- Make a piece of code to jump to "entry_label".
1091 -- This is the only arch-dependent bit.
1092 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1093 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1095 -- B8 ZZ YY XX WW FF E0
1096 (code0,code1,code2,code3,code4,code5,code6,code7)
1097 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1098 byte 2 entry_addr_w, byte 3 entry_addr_w,
1102 entry_addr_w :: Word32
1103 entry_addr_w = fromIntegral (addrToInt entry_addr)
1105 do addr <- mallocElem itbl
1106 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1107 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1108 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1110 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1113 byte :: Int -> Word32 -> Word32
1114 byte 0 w = w .&. 0xFF
1115 byte 1 w = (w `shiftR` 8) .&. 0xFF
1116 byte 2 w = (w `shiftR` 16) .&. 0xFF
1117 byte 3 w = (w `shiftR` 24) .&. 0xFF
1120 vecret_entry 0 = mci_constr1_entry
1121 vecret_entry 1 = mci_constr2_entry
1122 vecret_entry 2 = mci_constr3_entry
1123 vecret_entry 3 = mci_constr4_entry
1124 vecret_entry 4 = mci_constr5_entry
1125 vecret_entry 5 = mci_constr6_entry
1126 vecret_entry 6 = mci_constr7_entry
1127 vecret_entry 7 = mci_constr8_entry
1129 -- entry point for direct returns for created constr itbls
1130 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1131 -- and the 8 vectored ones
1132 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1133 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1134 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1135 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1136 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1137 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1138 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1139 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1143 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1146 -- Ultra-minimalist version specially for constructors
1147 data StgInfoTable = StgInfoTable {
1152 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1156 instance Storable StgInfoTable where
1159 = (sum . map (\f -> f itbl))
1160 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1161 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1162 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1165 = (sum . map (\f -> f itbl))
1166 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1167 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1168 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1171 = do a1 <- store (ptrs itbl) a0
1172 a2 <- store (nptrs itbl) a1
1173 a3 <- store (tipe itbl) a2
1174 a4 <- store (srtlen itbl) a3
1175 a5 <- store (code0 itbl) a4
1176 a6 <- store (code1 itbl) a5
1177 a7 <- store (code2 itbl) a6
1178 a8 <- store (code3 itbl) a7
1179 a9 <- store (code4 itbl) a8
1180 aA <- store (code5 itbl) a9
1181 aB <- store (code6 itbl) aA
1182 aC <- store (code7 itbl) aB
1186 = do (a1,ptrs) <- load a0
1187 (a2,nptrs) <- load a1
1188 (a3,tipe) <- load a2
1189 (a4,srtlen) <- load a3
1190 (a5,code0) <- load a4
1191 (a6,code1) <- load a5
1192 (a7,code2) <- load a6
1193 (a8,code3) <- load a7
1194 (a9,code4) <- load a8
1195 (aA,code5) <- load a9
1196 (aB,code6) <- load aA
1197 (aC,code7) <- load aB
1198 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1199 srtlen = srtlen, tipe = tipe,
1200 code0 = code0, code1 = code1, code2 = code2,
1201 code3 = code3, code4 = code4, code5 = code5,
1202 code6 = code6, code7 = code7 }
1204 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1205 fieldSz sel x = sizeOf (sel x)
1207 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1208 fieldAl sel x = alignment (sel x)
1210 store :: Storable a => a -> Addr -> IO Addr
1211 store x addr = do poke addr x
1212 return (addr `plusAddr` fromIntegral (sizeOf x))
1214 load :: Storable a => Addr -> IO (Addr, a)
1215 load addr = do x <- peek addr
1216 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1218 -----------------------------------------------------------------------------q
1220 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1222 #endif /* ndef GHCI */