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(..) )
66 import TyCon ( TyCon, isDataTyCon, tyConFamilySize, tyConDataCons )
67 import Class ( Class, classTyCon )
71 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
72 import OccName ( occNameString )
74 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_(rdrNameModule rn) ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
555 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
556 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
558 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
559 linkPrimAlt ie ce (AltPrim lit rhs)
560 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
562 linkDefault ie ce Nothing = Nothing
563 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
565 -- ---------------------------------------------------------------------------
566 -- The interpreter proper
567 -- ---------------------------------------------------------------------------
569 -- The dynamic environment contains everything boxed.
570 -- eval* functions which look up values in it will know the
571 -- representation of the thing they are looking up, so they
572 -- can cast/unbox it as necessary.
574 -- ---------------------------------------------------------------------------
575 -- Evaluator for things of boxed (pointer) representation
576 -- ---------------------------------------------------------------------------
578 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
582 -- | trace ("evalP: " ++ showExprTag expr) False
583 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
584 = error "evalP: ?!?!"
587 evalP (Native p) de = unsafeCoerce# p
589 -- First try the dynamic env. If that fails, assume it's a top-level
590 -- binding and look in the static env. That gives an Expr, which we
591 -- must convert to a boxed thingy by applying evalP to it. Because
592 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
593 -- CAFs), it's always safe to use evalP.
595 = case lookupUFM de v of
597 Nothing -> error ("evalP: lookupUFM " ++ show v)
599 -- Deal with application of a function returning a pointer rep
600 -- to arguments of any persuasion. Note that the function itself
601 -- always has pointer rep.
602 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
603 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
604 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
605 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
607 -- Lambdas always return P-rep, but we need to do different things
608 -- depending on both the argument and result representations.
610 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
612 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
614 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
616 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
618 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
620 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
622 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
624 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
626 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
628 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
630 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
632 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
634 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
636 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
638 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
640 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
643 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
644 -- except in the sense that we go on and evaluate the body with whichever
645 -- evaluator was used for the expression as a whole.
646 evalP (NonRecP bind e) de
647 = evalP e (augment_nonrec bind de)
648 evalP (RecP binds b) de
649 = evalP b (augment_rec binds de)
650 evalP (CaseAlgP bndr expr alts def) de
651 = case helper_caseAlg bndr expr alts def de of
652 (rhs, de') -> evalP rhs de'
653 evalP (CasePrimP bndr expr alts def) de
654 = case helper_casePrim bndr expr alts def de of
655 (rhs, de') -> evalP rhs de'
658 -- ConApp can only be handled by evalP
659 evalP (ConApp itbl args) se de
662 -- This appalling hack suggested (gleefully) by SDM
663 -- It is not well typed (needless to say?)
664 loop :: [Expr] -> boxed
666 = trace "loop-empty" (
667 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
670 = trace "loop-not-empty" (
672 RepI -> case evalI a de of i# -> loop as i#
673 RepP -> let p = evalP a de in loop as p
677 evalP (ConAppI (A# itbl) a1) de
678 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
680 evalP (ConApp (A# itbl)) de
681 = mci_make_constr itbl
683 evalP (ConAppP (A# itbl) a1) de
684 = let p1 = evalP a1 de
685 in mci_make_constrP itbl p1
687 evalP (ConAppPP (A# itbl) a1 a2) de
688 = let p1 = evalP a1 de
690 in mci_make_constrPP itbl p1 p2
692 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
693 = let p1 = evalP a1 de
696 in mci_make_constrPPP itbl p1 p2 p3
701 = error ("evalP: unhandled case: " ++ showExprTag other)
703 --------------------------------------------------------
704 --- Evaluator for things of Int# representation
705 --------------------------------------------------------
707 -- Evaluate something which has an unboxed Int rep
708 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
711 -- | trace ("evalI: " ++ showExprTag expr) False
712 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
713 = error "evalI: ?!?!"
715 evalI (LitI i#) de = i#
718 case lookupUFM de v of
719 Just e -> case unsafeCoerce# e of I# i -> i
720 Nothing -> error ("evalI: lookupUFM " ++ show v)
722 -- Deal with application of a function returning an Int# rep
723 -- to arguments of any persuasion. Note that the function itself
724 -- always has pointer rep.
725 evalI (AppII e1 e2) de
726 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
727 evalI (AppPI e1 e2) de
728 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
729 evalI (AppFI e1 e2) de
730 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
731 evalI (AppDI e1 e2) de
732 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
734 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
735 -- except in the sense that we go on and evaluate the body with whichever
736 -- evaluator was used for the expression as a whole.
737 evalI (NonRecI bind b) de
738 = evalI b (augment_nonrec bind de)
739 evalI (RecI binds b) de
740 = evalI b (augment_rec binds de)
741 evalI (CaseAlgI bndr expr alts def) de
742 = case helper_caseAlg bndr expr alts def de of
743 (rhs, de') -> evalI rhs de'
744 evalI (CasePrimI bndr expr alts def) de
745 = case helper_casePrim bndr expr alts def de of
746 (rhs, de') -> evalI rhs de'
748 -- evalI can't be applied to a lambda term, by defn, since those
751 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
752 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
754 --evalI (NonRec (IBind v e) b) de
755 -- = evalI b (augment de v (eval e de))
758 = error ("evalI: unhandled case: " ++ showExprTag other)
760 --------------------------------------------------------
761 --- Evaluator for things of Float# representation
762 --------------------------------------------------------
764 -- Evaluate something which has an unboxed Int rep
765 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
768 -- | trace ("evalF: " ++ showExprTag expr) False
769 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
770 = error "evalF: ?!?!"
772 evalF (LitF f#) de = f#
775 case lookupUFM de v of
776 Just e -> case unsafeCoerce# e of F# i -> i
777 Nothing -> error ("evalF: lookupUFM " ++ show v)
779 -- Deal with application of a function returning an Int# rep
780 -- to arguments of any persuasion. Note that the function itself
781 -- always has pointer rep.
782 evalF (AppIF e1 e2) de
783 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
784 evalF (AppPF e1 e2) de
785 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
786 evalF (AppFF e1 e2) de
787 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
788 evalF (AppDF e1 e2) de
789 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
791 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
792 -- except in the sense that we go on and evaluate the body with whichever
793 -- evaluator was used for the expression as a whole.
794 evalF (NonRecF bind b) de
795 = evalF b (augment_nonrec bind de)
796 evalF (RecF binds b) de
797 = evalF b (augment_rec binds de)
798 evalF (CaseAlgF bndr expr alts def) de
799 = case helper_caseAlg bndr expr alts def de of
800 (rhs, de') -> evalF rhs de'
801 evalF (CasePrimF bndr expr alts def) de
802 = case helper_casePrim bndr expr alts def de of
803 (rhs, de') -> evalF rhs de'
805 -- evalF can't be applied to a lambda term, by defn, since those
808 evalF (PrimOpF op _) de
809 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
812 = error ("evalF: unhandled case: " ++ showExprTag other)
814 --------------------------------------------------------
815 --- Evaluator for things of Double# representation
816 --------------------------------------------------------
818 -- Evaluate something which has an unboxed Int rep
819 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
822 -- | trace ("evalD: " ++ showExprTag expr) False
823 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
824 = error "evalD: ?!?!"
826 evalD (LitD d#) de = d#
829 case lookupUFM de v of
830 Just e -> case unsafeCoerce# e of D# i -> i
831 Nothing -> error ("evalD: lookupUFM " ++ show v)
833 -- Deal with application of a function returning an Int# rep
834 -- to arguments of any persuasion. Note that the function itself
835 -- always has pointer rep.
836 evalD (AppID e1 e2) de
837 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
838 evalD (AppPD e1 e2) de
839 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
840 evalD (AppFD e1 e2) de
841 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
842 evalD (AppDD e1 e2) de
843 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
845 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
846 -- except in the sense that we go on and evaluate the body with whichever
847 -- evaluator was used for the expression as a whole.
848 evalD (NonRecD bind b) de
849 = evalD b (augment_nonrec bind de)
850 evalD (RecD binds b) de
851 = evalD b (augment_rec binds de)
852 evalD (CaseAlgD bndr expr alts def) de
853 = case helper_caseAlg bndr expr alts def de of
854 (rhs, de') -> evalD rhs de'
855 evalD (CasePrimD bndr expr alts def) de
856 = case helper_casePrim bndr expr alts def de of
857 (rhs, de') -> evalD rhs de'
859 -- evalD can't be applied to a lambda term, by defn, since those
862 evalD (PrimOpD op _) de
863 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
866 = error ("evalD: unhandled case: " ++ showExprTag other)
868 --------------------------------------------------------
869 --- Helper bits and pieces
870 --------------------------------------------------------
872 -- Find the Rep of any Expr
873 repOf :: LinkedIExpr -> Rep
875 repOf (LamPP _ _) = RepP
876 repOf (LamPI _ _) = RepP
877 repOf (LamPF _ _) = RepP
878 repOf (LamPD _ _) = RepP
879 repOf (LamIP _ _) = RepP
880 repOf (LamII _ _) = RepP
881 repOf (LamIF _ _) = RepP
882 repOf (LamID _ _) = RepP
883 repOf (LamFP _ _) = RepP
884 repOf (LamFI _ _) = RepP
885 repOf (LamFF _ _) = RepP
886 repOf (LamFD _ _) = RepP
887 repOf (LamDP _ _) = RepP
888 repOf (LamDI _ _) = RepP
889 repOf (LamDF _ _) = RepP
890 repOf (LamDD _ _) = RepP
892 repOf (AppPP _ _) = RepP
893 repOf (AppPI _ _) = RepI
894 repOf (AppPF _ _) = RepF
895 repOf (AppPD _ _) = RepD
896 repOf (AppIP _ _) = RepP
897 repOf (AppII _ _) = RepI
898 repOf (AppIF _ _) = RepF
899 repOf (AppID _ _) = RepD
900 repOf (AppFP _ _) = RepP
901 repOf (AppFI _ _) = RepI
902 repOf (AppFF _ _) = RepF
903 repOf (AppFD _ _) = RepD
904 repOf (AppDP _ _) = RepP
905 repOf (AppDI _ _) = RepI
906 repOf (AppDF _ _) = RepF
907 repOf (AppDD _ _) = RepD
909 repOf (NonRecP _ _) = RepP
910 repOf (NonRecI _ _) = RepI
911 repOf (NonRecF _ _) = RepF
912 repOf (NonRecD _ _) = RepD
914 repOf (LitI _) = RepI
915 repOf (LitF _) = RepF
916 repOf (LitD _) = RepD
918 repOf (VarP _) = RepI
919 repOf (VarI _) = RepI
920 repOf (VarF _) = RepF
921 repOf (VarD _) = RepD
923 repOf (PrimOpP _ _) = RepP
924 repOf (PrimOpI _ _) = RepI
925 repOf (PrimOpF _ _) = RepF
926 repOf (PrimOpD _ _) = RepD
928 repOf (ConApp _) = RepP
929 repOf (ConAppI _ _) = RepP
930 repOf (ConAppP _ _) = RepP
931 repOf (ConAppPP _ _ _) = RepP
932 repOf (ConAppPPP _ _ _ _) = RepP
934 repOf (CaseAlgP _ _ _ _) = RepP
935 repOf (CaseAlgI _ _ _ _) = RepI
936 repOf (CaseAlgF _ _ _ _) = RepF
937 repOf (CaseAlgD _ _ _ _) = RepD
939 repOf (CasePrimP _ _ _ _) = RepP
940 repOf (CasePrimI _ _ _ _) = RepI
941 repOf (CasePrimF _ _ _ _) = RepF
942 repOf (CasePrimD _ _ _ _) = RepD
945 = error ("repOf: unhandled case: " ++ showExprTag other)
947 -- how big (in words) is one of these
948 repSizeW :: Rep -> Int
953 -- Evaluate an expression, using the appropriate evaluator,
954 -- then box up the result. Note that it's only safe to use this
955 -- to create values to put in the environment. You can't use it
956 -- to create a value which might get passed to native code since that
957 -- code will have no idea that unboxed things have been boxed.
958 eval :: LinkedIExpr -> UniqFM boxed -> boxed
961 RepI -> unsafeCoerce# (I# (evalI expr de))
962 RepP -> evalP expr de
963 RepF -> unsafeCoerce# (F# (evalF expr de))
964 RepD -> unsafeCoerce# (D# (evalD expr de))
966 -- Evaluate the scrutinee of a case, select an alternative,
967 -- augment the environment appropriately, and return the alt
968 -- and the augmented environment.
969 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
971 -> (LinkedIExpr, UniqFM boxed)
972 helper_caseAlg bndr expr alts def de
973 = let exprEv = evalP expr de
975 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
976 case select_altAlg (tagOf exprEv) alts def of
977 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
980 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
982 -> (LinkedIExpr, UniqFM boxed)
983 helper_casePrim bndr expr alts def de
985 -- Umm, can expr have any other rep? Yes ...
986 -- CharRep, DoubleRep, FloatRep. What about string reps?
987 RepI -> case evalI expr de of
988 i# -> (select_altPrim alts def (LitI i#),
989 addToUFM de bndr (unsafeCoerce# (I# i#)))
992 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
993 augment_from_constr de con ([],offset)
995 augment_from_constr de con ((v,rep):vs,offset)
998 RepP -> indexPtrOffClosure con offset
999 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1001 augment_from_constr (addToUFM de v v_binding) con
1002 (vs,offset + repSizeW rep)
1004 -- Augment the environment for a non-recursive let.
1005 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1006 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1008 -- Augment the environment for a recursive let.
1009 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1010 augment_rec binds de
1011 = let vars = map binder binds
1012 rhss = map bindee binds
1013 rhs_vs = map (\rhs -> eval rhs de') rhss
1014 de' = addListToUFM de (zip vars rhs_vs)
1018 -- a must be a constructor?
1020 tagOf x = I# (dataToTag# x)
1022 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1023 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1024 select_altAlg tag [] (Just def) = ([],def)
1025 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1028 else select_altAlg tag alts def
1030 -- literal may only be a literal, not an arbitrary expression
1031 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1032 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1033 select_altPrim [] (Just def) literal = def
1034 select_altPrim ((AltPrim lit rhs):alts) def literal
1035 = if eqLits lit literal
1037 else select_altPrim alts def literal
1039 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1042 -- a is a constructor
1043 indexPtrOffClosure :: a -> Int -> b
1044 indexPtrOffClosure con (I# offset)
1045 = case indexPtrOffClosure# con offset of (# x #) -> x
1047 indexIntOffClosure :: a -> Int -> Int#
1048 indexIntOffClosure con (I# offset)
1049 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1052 ------------------------------------------------------------------------
1053 --- Manufacturing of info tables for DataCons defined in this module ---
1054 ------------------------------------------------------------------------
1057 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1059 -- Assumes constructors are numbered from zero, not one
1060 make_constr_itbls :: [DataCon] -> IO ItblEnv
1061 make_constr_itbls cons
1063 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1064 return (listToFM is)
1066 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1067 return (listToFM is)
1069 mk_vecret_itbl (dcon, conNo)
1070 = mk_itbl dcon conNo (vecret_entry conNo)
1071 mk_dirret_itbl (dcon, conNo)
1072 = mk_itbl dcon conNo mci_constr_entry
1074 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1075 mk_itbl dcon conNo entry_addr
1076 = let (tot_wds, ptr_wds, _)
1077 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1079 nptrs = tot_wds - ptr_wds
1080 itbl = StgInfoTable {
1081 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1082 tipe = fromIntegral cONSTR,
1083 srtlen = fromIntegral conNo,
1084 code0 = fromIntegral code0, code1 = fromIntegral code1,
1085 code2 = fromIntegral code2, code3 = fromIntegral code3,
1086 code4 = fromIntegral code4, code5 = fromIntegral code5,
1087 code6 = fromIntegral code6, code7 = fromIntegral code7
1089 -- Make a piece of code to jump to "entry_label".
1090 -- This is the only arch-dependent bit.
1091 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1092 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1094 -- B8 ZZ YY XX WW FF E0
1095 (code0,code1,code2,code3,code4,code5,code6,code7)
1096 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1097 byte 2 entry_addr_w, byte 3 entry_addr_w,
1101 entry_addr_w :: Word32
1102 entry_addr_w = fromIntegral (addrToInt entry_addr)
1104 do addr <- mallocElem itbl
1105 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1106 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1107 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1109 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1112 byte :: Int -> Word32 -> Word32
1113 byte 0 w = w .&. 0xFF
1114 byte 1 w = (w `shiftR` 8) .&. 0xFF
1115 byte 2 w = (w `shiftR` 16) .&. 0xFF
1116 byte 3 w = (w `shiftR` 24) .&. 0xFF
1119 vecret_entry 0 = mci_constr1_entry
1120 vecret_entry 1 = mci_constr2_entry
1121 vecret_entry 2 = mci_constr3_entry
1122 vecret_entry 3 = mci_constr4_entry
1123 vecret_entry 4 = mci_constr5_entry
1124 vecret_entry 5 = mci_constr6_entry
1125 vecret_entry 6 = mci_constr7_entry
1126 vecret_entry 7 = mci_constr8_entry
1128 -- entry point for direct returns for created constr itbls
1129 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1130 -- and the 8 vectored ones
1131 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1132 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1133 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1134 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1135 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1136 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1137 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1138 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1142 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1145 -- Ultra-minimalist version specially for constructors
1146 data StgInfoTable = StgInfoTable {
1151 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1155 instance Storable StgInfoTable where
1158 = (sum . map (\f -> f itbl))
1159 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1160 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1161 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1164 = (sum . map (\f -> f itbl))
1165 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1166 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1167 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1170 = do a1 <- store (ptrs itbl) a0
1171 a2 <- store (nptrs itbl) a1
1172 a3 <- store (tipe itbl) a2
1173 a4 <- store (srtlen itbl) a3
1174 a5 <- store (code0 itbl) a4
1175 a6 <- store (code1 itbl) a5
1176 a7 <- store (code2 itbl) a6
1177 a8 <- store (code3 itbl) a7
1178 a9 <- store (code4 itbl) a8
1179 aA <- store (code5 itbl) a9
1180 aB <- store (code6 itbl) aA
1181 aC <- store (code7 itbl) aB
1185 = do (a1,ptrs) <- load a0
1186 (a2,nptrs) <- load a1
1187 (a3,tipe) <- load a2
1188 (a4,srtlen) <- load a3
1189 (a5,code0) <- load a4
1190 (a6,code1) <- load a5
1191 (a7,code2) <- load a6
1192 (a8,code3) <- load a7
1193 (a9,code4) <- load a8
1194 (aA,code5) <- load a9
1195 (aB,code6) <- load aA
1196 (aC,code7) <- load aB
1197 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1198 srtlen = srtlen, tipe = tipe,
1199 code0 = code0, code1 = code1, code2 = code2,
1200 code3 = code3, code4 = code4, code5 = code5,
1201 code6 = code6, code7 = code7 }
1203 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1204 fieldSz sel x = sizeOf (sel x)
1206 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1207 fieldAl sel x = alignment (sel x)
1209 store :: Storable a => a -> Addr -> IO Addr
1210 store x addr = do poke addr x
1211 return (addr `plusAddr` fromIntegral (sizeOf x))
1213 load :: Storable a => Addr -> IO (Addr, a)
1214 load addr = do x <- peek addr
1215 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1217 -----------------------------------------------------------------------------q
1219 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1221 #endif /* ndef GHCI */