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 stgToIBinds, -- :: [StgBinding] -> [UnlinkedIBind]
16 runStgI -- tmp, for testing
19 {- -----------------------------------------------------------------------------
22 - link should be in the IO monad, so it can modify the symtabs as it
25 - need a way to remove the bindings for a module from the symtabs.
26 maybe the symtabs should be indexed by module first.
28 - change the representation to something less verbose (?).
30 - converting string literals to Addr# is horrible and introduces
31 a memory leak. See if something can be done about this.
33 ----------------------------------------------------------------------------- -}
35 #include "HsVersions.h"
39 import Id ( Id, idPrimRep )
42 import PrimOp ( PrimOp(..) )
43 import PrimRep ( PrimRep(..) )
44 import Literal ( Literal(..) )
45 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
46 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
47 import ClosureInfo ( mkVirtHeapOffsets )
48 import Name ( toRdrName )
52 import {-# SOURCE #-} MCI_make_constr
54 import IOExts ( unsafePerformIO ) -- ToDo: remove
55 import PrelGHC --( unsafeCoerce#, dataToTag#,
56 -- indexPtrOffClosure#, indexWordOffClosure# )
57 import IO ( hPutStr, stderr )
59 import PrelAddr ( Addr(..) )
60 import PrelFloat ( Float(..), Double(..) )
66 import GlaExts ( Int(..) )
67 import Module ( moduleNameFS )
70 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
71 import Class ( Class )
75 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
77 import Panic ( panic )
78 import OccName ( occNameString )
81 -- ---------------------------------------------------------------------------
82 -- Environments needed by the linker
83 -- ---------------------------------------------------------------------------
85 type ItblEnv = FiniteMap RdrName Addr
86 type ClosureEnv = FiniteMap RdrName HValue
88 -- ---------------------------------------------------------------------------
89 -- Run our STG program through the interpreter
90 -- ---------------------------------------------------------------------------
92 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
95 runStgI = panic "StgInterp.runStgI: not implemented"
96 linkIModules = panic "StgInterp.linkIModules: not implemented"
101 -- the bindings need to have a binding for stgMain, and the
102 -- body of it had better represent something of type Int# -> Int#
103 runStgI tycons classes stgbinds
105 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
109 = "-------------------- Unlinked Binds --------------------\n"
110 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
113 hPutStr stderr dbg_txt
115 (linked_binds, ie, ce) <-
116 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
119 = "-------------------- Linked Binds --------------------\n"
120 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
123 hPutStr stderr dbg_txt
126 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
128 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
131 = I# (evalI (AppII stgMain (LitI 0#))
132 emptyUFM{-initial de-}
136 -- ---------------------------------------------------------------------------
137 -- Convert STG to an unlinked interpretable
138 -- ---------------------------------------------------------------------------
140 -- visible from outside
141 stgToIBinds :: [StgBinding] -> [UnlinkedIBind]
142 stgToIBinds = concatMap (translateBind emptyUniqSet)
144 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
145 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
146 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
147 where ie' = addListToUniqSet ie (map fst vs_n_es)
149 isRec (StgNonRec _ _) = False
150 isRec (StgRec _) = True
152 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
153 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
156 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
157 rhsRep = repOfStgExpr rhs
158 mkLambdas [] = rhsExpr
159 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
160 rhs2expr ie (StgRhsCon ccs dcon args)
161 = conapp2expr ie dcon args
163 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
164 conapp2expr ie dcon args
165 = mkConApp con_rdrname reps exprs
167 con_rdrname = toRdrName dcon
168 exprs = map (arg2expr ie) inHeapOrder
169 reps = map repOfArg inHeapOrder
170 inHeapOrder = toHeapOrder args
172 toHeapOrder :: [StgArg] -> [StgArg]
174 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
175 (rearranged, offsets) = unzip rearranged_w_offsets
179 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
181 -- Handle most common cases specially; do the rest with a generic
182 -- mechanism (deferred till later :)
183 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
184 mkConApp nm [] [] = ConApp nm
185 mkConApp nm [RepI] [a1] = ConAppI nm a1
186 mkConApp nm [RepP] [a1] = ConAppP nm a1
187 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
188 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
189 mkConApp nm reps args
190 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
192 mkLam RepP RepP = LamPP
193 mkLam RepI RepP = LamIP
194 mkLam RepP RepI = LamPI
195 mkLam RepI RepI = LamII
196 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
198 mkApp RepP RepP = AppPP
199 mkApp RepI RepP = AppIP
200 mkApp RepP RepI = AppPI
201 mkApp RepI RepI = AppII
202 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
205 repOfId = primRep2Rep . idPrimRep
210 -- genuine lifted types
213 -- all these are unboxed, fit into a word, and we assume they
214 -- all have the same call/return convention.
222 -- these are pretty dodgy: really pointers, but
223 -- we can't let the compiler build thunks with these reps.
224 ForeignObjRep -> RepP
225 StableNameRep -> RepP
230 other -> pprPanic "primRep2Rep" (ppr other)
232 repOfStgExpr :: StgExpr -> Rep
237 StgCase scrut live liveR bndr srt alts
238 -> case altRhss alts of
239 (a:_) -> repOfStgExpr a
240 [] -> panic "repOfStgExpr: no alts"
244 -> repOfApp ((deNoteType.repType.idType) var) (length args)
246 StgPrimApp op args res_ty
247 -> (primRep2Rep.typePrimRep) res_ty
249 StgLet binds body -> repOfStgExpr body
250 StgLetNoEscape live liveR binds body -> repOfStgExpr body
252 StgConApp con args -> RepP -- by definition
255 -> pprPanic "repOfStgExpr" (ppr other)
257 altRhss (StgAlgAlts ty alts def)
258 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
259 altRhss (StgPrimAlts ty alts def)
260 = [rhs | (lit,rhs) <- alts] ++ defRhs def
263 defRhs (StgBindDefault rhs)
266 -- returns the Rep of the result of applying ty to n args.
267 repOfApp :: Type -> Int -> Rep
268 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
269 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
281 MachStr _ -> RepI -- because it's a ptr outside the heap
282 other -> pprPanic "repOfLit" (ppr lit)
284 lit2expr :: Literal -> UnlinkedIExpr
287 MachInt i -> case fromIntegral i of I# i -> LitI i
288 MachWord i -> case fromIntegral i of I# i -> LitI i
289 MachAddr i -> case fromIntegral i of I# i -> LitI i
290 MachChar i -> case fromIntegral i of I# i -> LitI i
291 MachFloat f -> case fromRational f of F# f -> LitF f
292 MachDouble f -> case fromRational f of D# f -> LitD f
295 CharStr s i -> LitI (addr2Int# s)
298 -- sigh, a string in the heap is no good to us. We need a
299 -- static C pointer, since the type of a string literal is
300 -- Addr#. So, copy the string into C land and introduce a
301 -- memory leak at the same time.
303 case unsafePerformIO (do a <- malloc (n+1);
304 strncpy a ba (fromIntegral n);
305 writeCharOffAddr a n '\0'
307 of A# a -> LitI (addr2Int# a)
309 _ -> error "StgInterp.lit2expr: unhandled string constant type"
311 other -> pprPanic "lit2expr" (ppr lit)
313 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
317 -> mkVar ie (repOfId var) var
320 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
324 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
325 | repOfStgExpr scrut /= RepP
326 -> mkCasePrim (repOfStgExpr stgexpr)
327 bndr (stg2expr ie scrut)
331 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
332 | repOfStgExpr scrut == RepP
333 -> mkCaseAlg (repOfStgExpr stgexpr)
334 bndr (stg2expr ie scrut)
338 StgPrimApp op args res_ty
339 -> mkPrimOp (repOfStgExpr stgexpr)
340 op (map (arg2expr ie) args)
343 -> conapp2expr ie dcon args
345 StgLet binds@(StgNonRec v e) body
346 -> mkNonRec (repOfStgExpr stgexpr)
347 (head (translateBind ie binds))
348 (stg2expr (addOneToUniqSet ie v) body)
350 StgLet binds@(StgRec bs) body
351 -> mkRec (repOfStgExpr stgexpr)
352 (translateBind ie binds)
353 (stg2expr (addListToUniqSet ie (map fst bs)) body)
356 -> pprPanic "stg2expr" (ppr stgexpr)
359 = AltPrim (lit2expr lit) (stg2expr ie rhs)
360 doAlgAlt (dcon,vars,uses,rhs)
361 = AltAlg (dataConTag dcon - 1)
362 (map id2VaaRep (toHeapOrder vars))
363 (stg2expr (addListToUniqSet ie vars) rhs)
366 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
367 (rearranged,offsets) = unzip rearranged_w_offsets
371 def2expr StgNoDefault = Nothing
372 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
374 mkAppChain ie result_rep so_far []
376 mkAppChain ie result_rep so_far [a]
377 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
378 mkAppChain ie result_rep so_far (a:as)
379 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
381 mkCasePrim RepI = CasePrimI
382 mkCasePrim RepP = CasePrimP
384 mkCaseAlg RepI = CaseAlgI
385 mkCaseAlg RepP = CaseAlgP
387 -- any var that isn't in scope is turned into a Native
389 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
390 | otherwise = Native (toRdrName var)
394 mkNonRec RepI = NonRecI
395 mkNonRec RepP = NonRecP
397 mkPrimOp RepI = PrimOpI
398 mkPrimOp RepP = PrimOpP
400 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
401 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
402 arg2expr ie (StgLitArg lit) = lit2expr lit
403 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
405 repOfArg :: StgArg -> Rep
406 repOfArg (StgVarArg v) = repOfId v
407 repOfArg (StgLitArg lit) = repOfLit lit
408 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
410 id2VaaRep var = (var, repOfId var)
412 -- ---------------------------------------------------------------------------
413 -- Link an interpretable into something we can run
414 -- ---------------------------------------------------------------------------
416 linkIModules :: ItblEnv -> ClosureEnv -> [([TyCon],[UnlinkedIBind])] ->
417 IO ([LinkedIBind], ItblEnv, ClosureEnv)
418 linkIModules ie ce mods = do
419 let (tyconss, bindss) = unzip mods
420 tycons = concat tyconss
421 binds = concat bindss
422 top_level_binders = map (toRdrName.binder) binds
424 new_ie <- mkITbls (concat tyconss)
425 let new_ce = addListToFM ce (zip top_level_binders new_rhss)
426 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
427 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
428 (new_binds, final_ie, final_ce) = linkIBinds new_ie new_ce binds
430 return (new_binds, final_ie, final_ce)
432 -- We're supposed to augment the environments with the values of any
433 -- external functions/info tables we need as we go along, but that's a
434 -- lot of hassle so for now I'll look up external things as they crop
435 -- up and not cache them in the source symbol tables. The interpreted
436 -- code will still be referenced in the source symbol tables.
439 -- Make info tables for the data decls in this module
440 mkITbls :: [TyCon] -> IO ItblEnv
441 mkITbls [] = return emptyFM
442 mkITbls (tc:tcs) = do itbls <- mkITbl tc
443 itbls2 <- mkITbls tcs
444 return (itbls `plusFM` itbls2)
446 mkITbl :: TyCon -> IO ItblEnv
448 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
450 | not (isDataTyCon tc)
452 | n == length dcs -- paranoia; this is an assertion.
453 = make_constr_itbls dcs
455 dcs = tyConDataCons tc
456 n = tyConFamilySize tc
459 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] ->
460 ([LinkedIBind], ItblEnv, ClosureEnv)
461 linkIBinds ie ce binds
462 = (new_binds, ie, ce)
463 where new_binds = map (linkIBind ie ce) binds
465 linkIBinds' ie ce binds
466 = new_binds where (new_binds, ie, ce) = linkIBinds ie ce binds
468 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
470 linkIExpr ie ce expr = case expr of
472 CaseAlgP bndr expr alts dflt ->
473 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
474 (linkDefault ie ce dflt)
476 CaseAlgI bndr expr alts dflt ->
477 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
478 (linkDefault ie ce dflt)
480 CasePrimP bndr expr alts dflt ->
481 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
482 (linkDefault ie ce dflt)
484 CasePrimI bndr expr alts dflt ->
485 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
486 (linkDefault ie ce dflt)
489 ConApp (lookupCon ie con)
492 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
495 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
497 ConAppPP con arg0 arg1 ->
498 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
500 ConAppPPP con arg0 arg1 arg2 ->
501 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
502 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
504 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
505 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
507 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
508 RecP binds expr -> RecP (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
510 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
511 RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
517 Native var -> lookupNative ce var
519 VarP v -> lookupVar ce VarP v
520 VarI v -> lookupVar ce VarI v
522 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
523 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
524 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
525 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
527 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
528 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
529 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
530 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
533 case lookupFM ie con of
536 -- try looking up in the object files.
538 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
540 Nothing -> pprPanic "linkIExpr" (ppr con)
542 lookupNative ce var =
543 case lookupFM ce var of
546 -- try looking up in the object files.
547 let lbl = (rdrNameToCLabel var "closure")
548 addr = unsafePerformIO (lookupSymbol lbl) in
549 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
550 Just (A# addr) -> Native (unsafeCoerce# addr)
551 Nothing -> pprPanic "linkIExpr" (ppr var)
553 -- some VarI/VarP refer to top-level interpreted functions; we change
554 -- them into Natives here.
556 case lookupFM ce (toRdrName v) of
560 -- HACK!!! ToDo: cleaner
561 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
562 rdrNameToCLabel rn suffix =
563 _UNPK_(moduleNameFS (rdrNameModule rn))
564 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
566 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
567 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
569 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
570 linkPrimAlt ie ce (AltPrim lit rhs)
571 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
573 linkDefault ie ce Nothing = Nothing
574 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
576 -- ---------------------------------------------------------------------------
577 -- The interpreter proper
578 -- ---------------------------------------------------------------------------
580 -- The dynamic environment contains everything boxed.
581 -- eval* functions which look up values in it will know the
582 -- representation of the thing they are looking up, so they
583 -- can cast/unbox it as necessary.
585 -- ---------------------------------------------------------------------------
586 -- Evaluator for things of boxed (pointer) representation
587 -- ---------------------------------------------------------------------------
589 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
593 -- | trace ("evalP: " ++ showExprTag expr) False
594 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
595 = error "evalP: ?!?!"
598 evalP (Native p) de = unsafeCoerce# p
600 -- First try the dynamic env. If that fails, assume it's a top-level
601 -- binding and look in the static env. That gives an Expr, which we
602 -- must convert to a boxed thingy by applying evalP to it. Because
603 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
604 -- CAFs), it's always safe to use evalP.
606 = case lookupUFM de v of
608 Nothing -> error ("evalP: lookupUFM " ++ show v)
610 -- Deal with application of a function returning a pointer rep
611 -- to arguments of any persuasion. Note that the function itself
612 -- always has pointer rep.
613 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
614 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
615 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
616 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
618 -- Lambdas always return P-rep, but we need to do different things
619 -- depending on both the argument and result representations.
621 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
623 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
625 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
627 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
629 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
631 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
633 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
635 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
637 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
639 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
641 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
643 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
645 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
647 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
649 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
651 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
654 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
655 -- except in the sense that we go on and evaluate the body with whichever
656 -- evaluator was used for the expression as a whole.
657 evalP (NonRecP bind e) de
658 = evalP e (augment_nonrec bind de)
659 evalP (RecP binds b) de
660 = evalP b (augment_rec binds de)
661 evalP (CaseAlgP bndr expr alts def) de
662 = case helper_caseAlg bndr expr alts def de of
663 (rhs, de') -> evalP rhs de'
664 evalP (CasePrimP bndr expr alts def) de
665 = case helper_casePrim bndr expr alts def de of
666 (rhs, de') -> evalP rhs de'
669 -- ConApp can only be handled by evalP
670 evalP (ConApp itbl args) se de
673 -- This appalling hack suggested (gleefully) by SDM
674 -- It is not well typed (needless to say?)
675 loop :: [Expr] -> boxed
677 = trace "loop-empty" (
678 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
681 = trace "loop-not-empty" (
683 RepI -> case evalI a de of i# -> loop as i#
684 RepP -> let p = evalP a de in loop as p
688 evalP (ConAppI (A# itbl) a1) de
689 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
691 evalP (ConApp (A# itbl)) de
692 = mci_make_constr itbl
694 evalP (ConAppP (A# itbl) a1) de
695 = let p1 = evalP a1 de
696 in mci_make_constrP itbl p1
698 evalP (ConAppPP (A# itbl) a1 a2) de
699 = let p1 = evalP a1 de
701 in mci_make_constrPP itbl p1 p2
703 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
704 = let p1 = evalP a1 de
707 in mci_make_constrPPP itbl p1 p2 p3
712 = error ("evalP: unhandled case: " ++ showExprTag other)
714 --------------------------------------------------------
715 --- Evaluator for things of Int# representation
716 --------------------------------------------------------
718 -- Evaluate something which has an unboxed Int rep
719 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
722 -- | trace ("evalI: " ++ showExprTag expr) False
723 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
724 = error "evalI: ?!?!"
726 evalI (LitI i#) de = i#
729 case lookupUFM de v of
730 Just e -> case unsafeCoerce# e of I# i -> i
731 Nothing -> error ("evalI: lookupUFM " ++ show v)
733 -- Deal with application of a function returning an Int# rep
734 -- to arguments of any persuasion. Note that the function itself
735 -- always has pointer rep.
736 evalI (AppII e1 e2) de
737 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
738 evalI (AppPI e1 e2) de
739 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
740 evalI (AppFI e1 e2) de
741 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
742 evalI (AppDI e1 e2) de
743 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
745 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
746 -- except in the sense that we go on and evaluate the body with whichever
747 -- evaluator was used for the expression as a whole.
748 evalI (NonRecI bind b) de
749 = evalI b (augment_nonrec bind de)
750 evalI (RecI binds b) de
751 = evalI b (augment_rec binds de)
752 evalI (CaseAlgI bndr expr alts def) de
753 = case helper_caseAlg bndr expr alts def de of
754 (rhs, de') -> evalI rhs de'
755 evalI (CasePrimI bndr expr alts def) de
756 = case helper_casePrim bndr expr alts def de of
757 (rhs, de') -> evalI rhs de'
759 -- evalI can't be applied to a lambda term, by defn, since those
762 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
763 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
765 --evalI (NonRec (IBind v e) b) de
766 -- = evalI b (augment de v (eval e de))
769 = error ("evalI: unhandled case: " ++ showExprTag other)
771 --------------------------------------------------------
772 --- Evaluator for things of Float# representation
773 --------------------------------------------------------
775 -- Evaluate something which has an unboxed Int rep
776 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
779 -- | trace ("evalF: " ++ showExprTag expr) False
780 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
781 = error "evalF: ?!?!"
783 evalF (LitF f#) de = f#
786 case lookupUFM de v of
787 Just e -> case unsafeCoerce# e of F# i -> i
788 Nothing -> error ("evalF: lookupUFM " ++ show v)
790 -- Deal with application of a function returning an Int# rep
791 -- to arguments of any persuasion. Note that the function itself
792 -- always has pointer rep.
793 evalF (AppIF e1 e2) de
794 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
795 evalF (AppPF e1 e2) de
796 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
797 evalF (AppFF e1 e2) de
798 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
799 evalF (AppDF e1 e2) de
800 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
802 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
803 -- except in the sense that we go on and evaluate the body with whichever
804 -- evaluator was used for the expression as a whole.
805 evalF (NonRecF bind b) de
806 = evalF b (augment_nonrec bind de)
807 evalF (RecF binds b) de
808 = evalF b (augment_rec binds de)
809 evalF (CaseAlgF bndr expr alts def) de
810 = case helper_caseAlg bndr expr alts def de of
811 (rhs, de') -> evalF rhs de'
812 evalF (CasePrimF bndr expr alts def) de
813 = case helper_casePrim bndr expr alts def de of
814 (rhs, de') -> evalF rhs de'
816 -- evalF can't be applied to a lambda term, by defn, since those
819 evalF (PrimOpF op _) de
820 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
823 = error ("evalF: unhandled case: " ++ showExprTag other)
825 --------------------------------------------------------
826 --- Evaluator for things of Double# representation
827 --------------------------------------------------------
829 -- Evaluate something which has an unboxed Int rep
830 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
833 -- | trace ("evalD: " ++ showExprTag expr) False
834 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
835 = error "evalD: ?!?!"
837 evalD (LitD d#) de = d#
840 case lookupUFM de v of
841 Just e -> case unsafeCoerce# e of D# i -> i
842 Nothing -> error ("evalD: lookupUFM " ++ show v)
844 -- Deal with application of a function returning an Int# rep
845 -- to arguments of any persuasion. Note that the function itself
846 -- always has pointer rep.
847 evalD (AppID e1 e2) de
848 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
849 evalD (AppPD e1 e2) de
850 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
851 evalD (AppFD e1 e2) de
852 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
853 evalD (AppDD e1 e2) de
854 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
856 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
857 -- except in the sense that we go on and evaluate the body with whichever
858 -- evaluator was used for the expression as a whole.
859 evalD (NonRecD bind b) de
860 = evalD b (augment_nonrec bind de)
861 evalD (RecD binds b) de
862 = evalD b (augment_rec binds de)
863 evalD (CaseAlgD bndr expr alts def) de
864 = case helper_caseAlg bndr expr alts def de of
865 (rhs, de') -> evalD rhs de'
866 evalD (CasePrimD bndr expr alts def) de
867 = case helper_casePrim bndr expr alts def de of
868 (rhs, de') -> evalD rhs de'
870 -- evalD can't be applied to a lambda term, by defn, since those
873 evalD (PrimOpD op _) de
874 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
877 = error ("evalD: unhandled case: " ++ showExprTag other)
879 --------------------------------------------------------
880 --- Helper bits and pieces
881 --------------------------------------------------------
883 -- Find the Rep of any Expr
884 repOf :: LinkedIExpr -> Rep
886 repOf (LamPP _ _) = RepP
887 repOf (LamPI _ _) = RepP
888 repOf (LamPF _ _) = RepP
889 repOf (LamPD _ _) = RepP
890 repOf (LamIP _ _) = RepP
891 repOf (LamII _ _) = RepP
892 repOf (LamIF _ _) = RepP
893 repOf (LamID _ _) = RepP
894 repOf (LamFP _ _) = RepP
895 repOf (LamFI _ _) = RepP
896 repOf (LamFF _ _) = RepP
897 repOf (LamFD _ _) = RepP
898 repOf (LamDP _ _) = RepP
899 repOf (LamDI _ _) = RepP
900 repOf (LamDF _ _) = RepP
901 repOf (LamDD _ _) = RepP
903 repOf (AppPP _ _) = RepP
904 repOf (AppPI _ _) = RepI
905 repOf (AppPF _ _) = RepF
906 repOf (AppPD _ _) = RepD
907 repOf (AppIP _ _) = RepP
908 repOf (AppII _ _) = RepI
909 repOf (AppIF _ _) = RepF
910 repOf (AppID _ _) = RepD
911 repOf (AppFP _ _) = RepP
912 repOf (AppFI _ _) = RepI
913 repOf (AppFF _ _) = RepF
914 repOf (AppFD _ _) = RepD
915 repOf (AppDP _ _) = RepP
916 repOf (AppDI _ _) = RepI
917 repOf (AppDF _ _) = RepF
918 repOf (AppDD _ _) = RepD
920 repOf (NonRecP _ _) = RepP
921 repOf (NonRecI _ _) = RepI
922 repOf (NonRecF _ _) = RepF
923 repOf (NonRecD _ _) = RepD
925 repOf (LitI _) = RepI
926 repOf (LitF _) = RepF
927 repOf (LitD _) = RepD
929 repOf (VarP _) = RepI
930 repOf (VarI _) = RepI
931 repOf (VarF _) = RepF
932 repOf (VarD _) = RepD
934 repOf (PrimOpP _ _) = RepP
935 repOf (PrimOpI _ _) = RepI
936 repOf (PrimOpF _ _) = RepF
937 repOf (PrimOpD _ _) = RepD
939 repOf (ConApp _) = RepP
940 repOf (ConAppI _ _) = RepP
941 repOf (ConAppP _ _) = RepP
942 repOf (ConAppPP _ _ _) = RepP
943 repOf (ConAppPPP _ _ _ _) = RepP
945 repOf (CaseAlgP _ _ _ _) = RepP
946 repOf (CaseAlgI _ _ _ _) = RepI
947 repOf (CaseAlgF _ _ _ _) = RepF
948 repOf (CaseAlgD _ _ _ _) = RepD
950 repOf (CasePrimP _ _ _ _) = RepP
951 repOf (CasePrimI _ _ _ _) = RepI
952 repOf (CasePrimF _ _ _ _) = RepF
953 repOf (CasePrimD _ _ _ _) = RepD
956 = error ("repOf: unhandled case: " ++ showExprTag other)
958 -- how big (in words) is one of these
959 repSizeW :: Rep -> Int
964 -- Evaluate an expression, using the appropriate evaluator,
965 -- then box up the result. Note that it's only safe to use this
966 -- to create values to put in the environment. You can't use it
967 -- to create a value which might get passed to native code since that
968 -- code will have no idea that unboxed things have been boxed.
969 eval :: LinkedIExpr -> UniqFM boxed -> boxed
972 RepI -> unsafeCoerce# (I# (evalI expr de))
973 RepP -> evalP expr de
974 RepF -> unsafeCoerce# (F# (evalF expr de))
975 RepD -> unsafeCoerce# (D# (evalD expr de))
977 -- Evaluate the scrutinee of a case, select an alternative,
978 -- augment the environment appropriately, and return the alt
979 -- and the augmented environment.
980 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
982 -> (LinkedIExpr, UniqFM boxed)
983 helper_caseAlg bndr expr alts def de
984 = let exprEv = evalP expr de
986 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
987 case select_altAlg (tagOf exprEv) alts def of
988 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
991 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
993 -> (LinkedIExpr, UniqFM boxed)
994 helper_casePrim bndr expr alts def de
996 -- Umm, can expr have any other rep? Yes ...
997 -- CharRep, DoubleRep, FloatRep. What about string reps?
998 RepI -> case evalI expr de of
999 i# -> (select_altPrim alts def (LitI i#),
1000 addToUFM de bndr (unsafeCoerce# (I# i#)))
1003 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1004 augment_from_constr de con ([],offset)
1006 augment_from_constr de con ((v,rep):vs,offset)
1009 RepP -> indexPtrOffClosure con offset
1010 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1012 augment_from_constr (addToUFM de v v_binding) con
1013 (vs,offset + repSizeW rep)
1015 -- Augment the environment for a non-recursive let.
1016 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1017 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1019 -- Augment the environment for a recursive let.
1020 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1021 augment_rec binds de
1022 = let vars = map binder binds
1023 rhss = map bindee binds
1024 rhs_vs = map (\rhs -> eval rhs de') rhss
1025 de' = addListToUFM de (zip vars rhs_vs)
1029 -- a must be a constructor?
1031 tagOf x = I# (dataToTag# x)
1033 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1034 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1035 select_altAlg tag [] (Just def) = ([],def)
1036 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1039 else select_altAlg tag alts def
1041 -- literal may only be a literal, not an arbitrary expression
1042 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1043 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1044 select_altPrim [] (Just def) literal = def
1045 select_altPrim ((AltPrim lit rhs):alts) def literal
1046 = if eqLits lit literal
1048 else select_altPrim alts def literal
1050 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1053 -- a is a constructor
1054 indexPtrOffClosure :: a -> Int -> b
1055 indexPtrOffClosure con (I# offset)
1056 = case indexPtrOffClosure# con offset of (# x #) -> x
1058 indexIntOffClosure :: a -> Int -> Int#
1059 indexIntOffClosure con (I# offset)
1060 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1063 ------------------------------------------------------------------------
1064 --- Manufacturing of info tables for DataCons defined in this module ---
1065 ------------------------------------------------------------------------
1068 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1070 -- Assumes constructors are numbered from zero, not one
1071 make_constr_itbls :: [DataCon] -> IO ItblEnv
1072 make_constr_itbls cons
1074 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1075 return (listToFM is)
1077 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1078 return (listToFM is)
1080 mk_vecret_itbl (dcon, conNo)
1081 = mk_itbl dcon conNo (vecret_entry conNo)
1082 mk_dirret_itbl (dcon, conNo)
1083 = mk_itbl dcon conNo mci_constr_entry
1085 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1086 mk_itbl dcon conNo entry_addr
1087 = let (tot_wds, ptr_wds, _)
1088 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1090 nptrs = tot_wds - ptr_wds
1091 itbl = StgInfoTable {
1092 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1093 tipe = fromIntegral cONSTR,
1094 srtlen = fromIntegral conNo,
1095 code0 = fromIntegral code0, code1 = fromIntegral code1,
1096 code2 = fromIntegral code2, code3 = fromIntegral code3,
1097 code4 = fromIntegral code4, code5 = fromIntegral code5,
1098 code6 = fromIntegral code6, code7 = fromIntegral code7
1100 -- Make a piece of code to jump to "entry_label".
1101 -- This is the only arch-dependent bit.
1102 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1103 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1105 -- B8 ZZ YY XX WW FF E0
1106 (code0,code1,code2,code3,code4,code5,code6,code7)
1107 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1108 byte 2 entry_addr_w, byte 3 entry_addr_w,
1112 entry_addr_w :: Word32
1113 entry_addr_w = fromIntegral (addrToInt entry_addr)
1115 do addr <- mallocElem itbl
1116 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1117 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1118 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1120 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1123 byte :: Int -> Word32 -> Word32
1124 byte 0 w = w .&. 0xFF
1125 byte 1 w = (w `shiftR` 8) .&. 0xFF
1126 byte 2 w = (w `shiftR` 16) .&. 0xFF
1127 byte 3 w = (w `shiftR` 24) .&. 0xFF
1130 vecret_entry 0 = mci_constr1_entry
1131 vecret_entry 1 = mci_constr2_entry
1132 vecret_entry 2 = mci_constr3_entry
1133 vecret_entry 3 = mci_constr4_entry
1134 vecret_entry 4 = mci_constr5_entry
1135 vecret_entry 5 = mci_constr6_entry
1136 vecret_entry 6 = mci_constr7_entry
1137 vecret_entry 7 = mci_constr8_entry
1139 -- entry point for direct returns for created constr itbls
1140 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1141 -- and the 8 vectored ones
1142 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1143 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1144 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1145 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1146 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1147 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1148 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1149 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1153 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1156 -- Ultra-minimalist version specially for constructors
1157 data StgInfoTable = StgInfoTable {
1162 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1166 instance Storable StgInfoTable where
1169 = (sum . map (\f -> f itbl))
1170 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1171 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1172 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1175 = (sum . map (\f -> f itbl))
1176 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1177 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1178 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1181 = do a1 <- store (ptrs itbl) a0
1182 a2 <- store (nptrs itbl) a1
1183 a3 <- store (tipe itbl) a2
1184 a4 <- store (srtlen itbl) a3
1185 a5 <- store (code0 itbl) a4
1186 a6 <- store (code1 itbl) a5
1187 a7 <- store (code2 itbl) a6
1188 a8 <- store (code3 itbl) a7
1189 a9 <- store (code4 itbl) a8
1190 aA <- store (code5 itbl) a9
1191 aB <- store (code6 itbl) aA
1192 aC <- store (code7 itbl) aB
1196 = do (a1,ptrs) <- load a0
1197 (a2,nptrs) <- load a1
1198 (a3,tipe) <- load a2
1199 (a4,srtlen) <- load a3
1200 (a5,code0) <- load a4
1201 (a6,code1) <- load a5
1202 (a7,code2) <- load a6
1203 (a8,code3) <- load a7
1204 (a9,code4) <- load a8
1205 (aA,code5) <- load a9
1206 (aB,code6) <- load aA
1207 (aC,code7) <- load aB
1208 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1209 srtlen = srtlen, tipe = tipe,
1210 code0 = code0, code1 = code1, code2 = code2,
1211 code3 = code3, code4 = code4, code5 = code5,
1212 code6 = code6, code7 = code7 }
1214 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1215 fieldSz sel x = sizeOf (sel x)
1217 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1218 fieldAl sel x = alignment (sel x)
1220 store :: Storable a => a -> Addr -> IO Addr
1221 store x addr = do poke addr x
1222 return (addr `plusAddr` fromIntegral (sizeOf x))
1224 load :: Storable a => Addr -> IO (Addr, a)
1225 load addr = do x <- peek addr
1226 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1228 -----------------------------------------------------------------------------q
1230 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1232 #endif /* ndef GHCI */