2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
14 {- -----------------------------------------------------------------------------
17 - link should be in the IO monad, so it can modify the symtabs as it
20 - need a way to remove the bindings for a module from the symtabs.
21 maybe the symtabs should be indexed by module first.
23 - change the representation to something less verbose (?).
25 - converting string literals to Addr# is horrible and introduces
26 a memory leak. See if something can be done about this.
28 ----------------------------------------------------------------------------- -}
30 #include "HsVersions.h"
32 #if __GLASGOW_HASKELL__ <= 408
34 import Panic ( panic )
35 import RdrName ( RdrName )
36 import PrelAddr ( Addr )
37 import FiniteMap ( FiniteMap )
38 import InterpSyn ( HValue )
40 type ItblEnv = FiniteMap RdrName Addr
41 type ClosureEnv = FiniteMap RdrName HValue
42 linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
43 stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
48 import Id ( Id, idPrimRep )
51 import PrimOp ( PrimOp(..) )
52 import PrimRep ( PrimRep(..) )
53 import Literal ( Literal(..) )
54 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
55 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
56 import ClosureInfo ( mkVirtHeapOffsets )
57 import Name ( toRdrName )
61 import {-# SOURCE #-} MCI_make_constr
63 import IOExts ( unsafePerformIO ) -- ToDo: remove
64 import PrelGHC --( unsafeCoerce#, dataToTag#,
65 -- indexPtrOffClosure#, indexWordOffClosure# )
66 import IO ( hPutStr, stderr )
68 import PrelAddr ( Addr(..) )
69 import PrelFloat ( Float(..), Double(..) )
75 import GlaExts ( Int(..) )
76 import Module ( moduleNameFS )
78 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
79 import Class ( Class, classTyCon )
83 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
85 import Panic ( panic )
86 import OccName ( occNameString )
89 -- ---------------------------------------------------------------------------
90 -- Environments needed by the linker
91 -- ---------------------------------------------------------------------------
93 type ItblEnv = FiniteMap RdrName Addr
94 type ClosureEnv = FiniteMap RdrName HValue
96 -- ---------------------------------------------------------------------------
97 -- Run our STG program through the interpreter
98 -- ---------------------------------------------------------------------------
101 -- To be nuked at some point soon.
102 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
104 -- the bindings need to have a binding for stgMain, and the
105 -- body of it had better represent something of type Int# -> Int#
106 runStgI tycons classes stgbinds
108 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
112 = "-------------------- Unlinked Binds --------------------\n"
113 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
116 hPutStr stderr dbg_txt
118 (linked_binds, ie, ce) <-
119 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
122 = "-------------------- Linked Binds --------------------\n"
123 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
126 hPutStr stderr dbg_txt
129 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
131 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
134 = I# (evalI (AppII stgMain (LitI 0#))
135 emptyUFM{-initial de-}
140 -- ---------------------------------------------------------------------------
141 -- Convert STG to an unlinked interpretable
142 -- ---------------------------------------------------------------------------
144 -- visible from outside
145 stgToInterpSyn :: [StgBinding]
146 -> [TyCon] -> [Class]
147 -> IO ([UnlinkedIBind], ItblEnv)
148 stgToInterpSyn binds local_tycons local_classes
149 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
150 let tycs = local_tycons ++ map classTyCon local_classes
151 itblenv <- mkITbls tycs
152 return (ibinds, itblenv)
155 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
156 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
157 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
158 where ie' = addListToUniqSet ie (map fst vs_n_es)
160 isRec (StgNonRec _ _) = False
161 isRec (StgRec _) = True
163 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
164 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
167 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
168 rhsRep = repOfStgExpr rhs
169 mkLambdas [] = rhsExpr
170 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
171 rhs2expr ie (StgRhsCon ccs dcon args)
172 = conapp2expr ie dcon args
174 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
175 conapp2expr ie dcon args
176 = mkConApp con_rdrname reps exprs
178 con_rdrname = toRdrName dcon
179 exprs = map (arg2expr ie) inHeapOrder
180 reps = map repOfArg inHeapOrder
181 inHeapOrder = toHeapOrder args
183 toHeapOrder :: [StgArg] -> [StgArg]
185 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
186 (rearranged, offsets) = unzip rearranged_w_offsets
190 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
192 -- Handle most common cases specially; do the rest with a generic
193 -- mechanism (deferred till later :)
194 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
195 mkConApp nm [] [] = ConApp nm
196 mkConApp nm [RepI] [a1] = ConAppI nm a1
197 mkConApp nm [RepP] [a1] = ConAppP nm a1
198 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
199 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
200 mkConApp nm reps args
201 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
203 mkLam RepP RepP = LamPP
204 mkLam RepI RepP = LamIP
205 mkLam RepP RepI = LamPI
206 mkLam RepI RepI = LamII
207 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
209 mkApp RepP RepP = AppPP
210 mkApp RepI RepP = AppIP
211 mkApp RepP RepI = AppPI
212 mkApp RepI RepI = AppII
213 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
216 repOfId = primRep2Rep . idPrimRep
221 -- genuine lifted types
224 -- all these are unboxed, fit into a word, and we assume they
225 -- all have the same call/return convention.
233 -- these are pretty dodgy: really pointers, but
234 -- we can't let the compiler build thunks with these reps.
235 ForeignObjRep -> RepP
236 StableNameRep -> RepP
241 other -> pprPanic "primRep2Rep" (ppr other)
243 repOfStgExpr :: StgExpr -> Rep
248 StgCase scrut live liveR bndr srt alts
249 -> case altRhss alts of
250 (a:_) -> repOfStgExpr a
251 [] -> panic "repOfStgExpr: no alts"
255 -> repOfApp ((deNoteType.repType.idType) var) (length args)
257 StgPrimApp op args res_ty
258 -> (primRep2Rep.typePrimRep) res_ty
260 StgLet binds body -> repOfStgExpr body
261 StgLetNoEscape live liveR binds body -> repOfStgExpr body
263 StgConApp con args -> RepP -- by definition
266 -> pprPanic "repOfStgExpr" (ppr other)
268 altRhss (StgAlgAlts ty alts def)
269 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
270 altRhss (StgPrimAlts ty alts def)
271 = [rhs | (lit,rhs) <- alts] ++ defRhs def
274 defRhs (StgBindDefault rhs)
277 -- returns the Rep of the result of applying ty to n args.
278 repOfApp :: Type -> Int -> Rep
279 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
280 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
292 MachStr _ -> RepI -- because it's a ptr outside the heap
293 other -> pprPanic "repOfLit" (ppr lit)
295 lit2expr :: Literal -> UnlinkedIExpr
298 MachInt i -> case fromIntegral i of I# i -> LitI i
299 MachWord i -> case fromIntegral i of I# i -> LitI i
300 MachAddr i -> case fromIntegral i of I# i -> LitI i
301 MachChar i -> case fromIntegral i of I# i -> LitI i
302 MachFloat f -> case fromRational f of F# f -> LitF f
303 MachDouble f -> case fromRational f of D# f -> LitD f
306 CharStr s i -> LitI (addr2Int# s)
309 -- sigh, a string in the heap is no good to us. We need a
310 -- static C pointer, since the type of a string literal is
311 -- Addr#. So, copy the string into C land and introduce a
312 -- memory leak at the same time.
314 case unsafePerformIO (do a <- malloc (n+1);
315 strncpy a ba (fromIntegral n);
316 writeCharOffAddr a n '\0'
318 of A# a -> LitI (addr2Int# a)
320 _ -> error "StgInterp.lit2expr: unhandled string constant type"
322 other -> pprPanic "lit2expr" (ppr lit)
324 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
328 -> mkVar ie (repOfId var) var
331 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
335 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
336 | repOfStgExpr scrut /= RepP
337 -> mkCasePrim (repOfStgExpr stgexpr)
338 bndr (stg2expr ie scrut)
342 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
343 | repOfStgExpr scrut == RepP
344 -> mkCaseAlg (repOfStgExpr stgexpr)
345 bndr (stg2expr ie scrut)
349 StgPrimApp op args res_ty
350 -> mkPrimOp (repOfStgExpr stgexpr)
351 op (map (arg2expr ie) args)
354 -> conapp2expr ie dcon args
356 StgLet binds@(StgNonRec v e) body
357 -> mkNonRec (repOfStgExpr stgexpr)
358 (head (translateBind ie binds))
359 (stg2expr (addOneToUniqSet ie v) body)
361 StgLet binds@(StgRec bs) body
362 -> mkRec (repOfStgExpr stgexpr)
363 (translateBind ie binds)
364 (stg2expr (addListToUniqSet ie (map fst bs)) body)
367 -> pprPanic "stg2expr" (ppr stgexpr)
370 = AltPrim (lit2expr lit) (stg2expr ie rhs)
371 doAlgAlt (dcon,vars,uses,rhs)
372 = AltAlg (dataConTag dcon - 1)
373 (map id2VaaRep (toHeapOrder vars))
374 (stg2expr (addListToUniqSet ie vars) rhs)
377 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
378 (rearranged,offsets) = unzip rearranged_w_offsets
382 def2expr StgNoDefault = Nothing
383 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
385 mkAppChain ie result_rep so_far []
387 mkAppChain ie result_rep so_far [a]
388 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
389 mkAppChain ie result_rep so_far (a:as)
390 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
392 mkCasePrim RepI = CasePrimI
393 mkCasePrim RepP = CasePrimP
395 mkCaseAlg RepI = CaseAlgI
396 mkCaseAlg RepP = CaseAlgP
398 -- any var that isn't in scope is turned into a Native
400 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
401 | otherwise = Native (toRdrName var)
405 mkNonRec RepI = NonRecI
406 mkNonRec RepP = NonRecP
408 mkPrimOp RepI = PrimOpI
409 mkPrimOp RepP = PrimOpP
411 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
412 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
413 arg2expr ie (StgLitArg lit) = lit2expr lit
414 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
416 repOfArg :: StgArg -> Rep
417 repOfArg (StgVarArg v) = repOfId v
418 repOfArg (StgLitArg lit) = repOfLit lit
419 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
421 id2VaaRep var = (var, repOfId var)
424 -- ---------------------------------------------------------------------------
425 -- Link interpretables into something we can run
426 -- ---------------------------------------------------------------------------
428 linkIModules :: ClosureEnv -- incoming global closure env; returned updated
429 -> ItblEnv -- incoming global itbl env; returned updated
430 -> [([UnlinkedIBind], ItblEnv)]
431 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
432 linkIModules gce gie mods = do
433 let (bindss, ies) = unzip mods
434 binds = concat bindss
435 top_level_binders = map (toRdrName.binder) binds
436 final_gie = foldr plusFM gie ies
439 new_gce = addListToFM gce (zip top_level_binders new_rhss)
440 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
441 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
442 new_binds = linkIBinds final_gie new_gce binds
444 return (new_binds, final_gie, new_gce)
447 -- We're supposed to augment the environments with the values of any
448 -- external functions/info tables we need as we go along, but that's a
449 -- lot of hassle so for now I'll look up external things as they crop
450 -- up and not cache them in the source symbol tables. The interpreted
451 -- code will still be referenced in the source symbol tables.
453 -- JRS 001025: above comment is probably out of date ... interpret
456 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
457 linkIBinds ie ce binds = map (linkIBind ie ce) binds
459 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
461 linkIExpr ie ce expr = case expr of
463 CaseAlgP bndr expr alts dflt ->
464 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
465 (linkDefault ie ce dflt)
467 CaseAlgI bndr expr alts dflt ->
468 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
469 (linkDefault ie ce dflt)
471 CasePrimP bndr expr alts dflt ->
472 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
473 (linkDefault ie ce dflt)
475 CasePrimI bndr expr alts dflt ->
476 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
477 (linkDefault ie ce dflt)
480 ConApp (lookupCon ie con)
483 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
486 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
488 ConAppPP con arg0 arg1 ->
489 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
491 ConAppPPP con arg0 arg1 arg2 ->
492 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
493 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
495 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
496 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
498 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
499 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
501 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
502 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
508 Native var -> lookupNative ce var
510 VarP v -> lookupVar ce VarP v
511 VarI v -> lookupVar ce VarI v
513 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
514 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
515 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
516 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
518 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
519 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
520 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
521 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
524 case lookupFM ie con of
527 -- try looking up in the object files.
529 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
531 Nothing -> pprPanic "linkIExpr" (ppr con)
533 lookupNative ce var =
534 case lookupFM ce var of
537 -- try looking up in the object files.
538 let lbl = (rdrNameToCLabel var "closure")
539 addr = unsafePerformIO (lookupSymbol lbl) in
540 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
541 Just (A# addr) -> Native (unsafeCoerce# addr)
542 Nothing -> pprPanic "linkIExpr" (ppr var)
544 -- some VarI/VarP refer to top-level interpreted functions; we change
545 -- them into Natives here.
547 case lookupFM ce (toRdrName v) of
551 -- HACK!!! ToDo: cleaner
552 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
553 rdrNameToCLabel rn suffix =
554 _UNPK_(moduleNameFS (rdrNameModule rn))
555 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
557 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
558 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
560 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
561 linkPrimAlt ie ce (AltPrim lit rhs)
562 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
564 linkDefault ie ce Nothing = Nothing
565 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
567 -- ---------------------------------------------------------------------------
568 -- The interpreter proper
569 -- ---------------------------------------------------------------------------
571 -- The dynamic environment contains everything boxed.
572 -- eval* functions which look up values in it will know the
573 -- representation of the thing they are looking up, so they
574 -- can cast/unbox it as necessary.
576 -- ---------------------------------------------------------------------------
577 -- Evaluator for things of boxed (pointer) representation
578 -- ---------------------------------------------------------------------------
580 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
584 -- | trace ("evalP: " ++ showExprTag expr) False
585 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
586 = error "evalP: ?!?!"
589 evalP (Native p) de = unsafeCoerce# p
591 -- First try the dynamic env. If that fails, assume it's a top-level
592 -- binding and look in the static env. That gives an Expr, which we
593 -- must convert to a boxed thingy by applying evalP to it. Because
594 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
595 -- CAFs), it's always safe to use evalP.
597 = case lookupUFM de v of
599 Nothing -> error ("evalP: lookupUFM " ++ show v)
601 -- Deal with application of a function returning a pointer rep
602 -- to arguments of any persuasion. Note that the function itself
603 -- always has pointer rep.
604 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
605 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
606 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
607 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
609 -- Lambdas always return P-rep, but we need to do different things
610 -- depending on both the argument and result representations.
612 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
614 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
616 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
618 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
620 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
622 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
624 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
626 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
628 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
630 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
632 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
634 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
636 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
638 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
640 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
642 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
645 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
646 -- except in the sense that we go on and evaluate the body with whichever
647 -- evaluator was used for the expression as a whole.
648 evalP (NonRecP bind e) de
649 = evalP e (augment_nonrec bind de)
650 evalP (RecP binds b) de
651 = evalP b (augment_rec binds de)
652 evalP (CaseAlgP bndr expr alts def) de
653 = case helper_caseAlg bndr expr alts def de of
654 (rhs, de') -> evalP rhs de'
655 evalP (CasePrimP bndr expr alts def) de
656 = case helper_casePrim bndr expr alts def de of
657 (rhs, de') -> evalP rhs de'
660 -- ConApp can only be handled by evalP
661 evalP (ConApp itbl args) se de
664 -- This appalling hack suggested (gleefully) by SDM
665 -- It is not well typed (needless to say?)
666 loop :: [Expr] -> boxed
668 = trace "loop-empty" (
669 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
672 = trace "loop-not-empty" (
674 RepI -> case evalI a de of i# -> loop as i#
675 RepP -> let p = evalP a de in loop as p
679 evalP (ConAppI (A# itbl) a1) de
680 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
682 evalP (ConApp (A# itbl)) de
683 = mci_make_constr itbl
685 evalP (ConAppP (A# itbl) a1) de
686 = let p1 = evalP a1 de
687 in mci_make_constrP itbl p1
689 evalP (ConAppPP (A# itbl) a1 a2) de
690 = let p1 = evalP a1 de
692 in mci_make_constrPP itbl p1 p2
694 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
695 = let p1 = evalP a1 de
698 in mci_make_constrPPP itbl p1 p2 p3
703 = error ("evalP: unhandled case: " ++ showExprTag other)
705 --------------------------------------------------------
706 --- Evaluator for things of Int# representation
707 --------------------------------------------------------
709 -- Evaluate something which has an unboxed Int rep
710 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
713 -- | trace ("evalI: " ++ showExprTag expr) False
714 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
715 = error "evalI: ?!?!"
717 evalI (LitI i#) de = i#
720 case lookupUFM de v of
721 Just e -> case unsafeCoerce# e of I# i -> i
722 Nothing -> error ("evalI: lookupUFM " ++ show v)
724 -- Deal with application of a function returning an Int# rep
725 -- to arguments of any persuasion. Note that the function itself
726 -- always has pointer rep.
727 evalI (AppII e1 e2) de
728 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
729 evalI (AppPI e1 e2) de
730 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
731 evalI (AppFI e1 e2) de
732 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
733 evalI (AppDI e1 e2) de
734 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
736 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
737 -- except in the sense that we go on and evaluate the body with whichever
738 -- evaluator was used for the expression as a whole.
739 evalI (NonRecI bind b) de
740 = evalI b (augment_nonrec bind de)
741 evalI (RecI binds b) de
742 = evalI b (augment_rec binds de)
743 evalI (CaseAlgI bndr expr alts def) de
744 = case helper_caseAlg bndr expr alts def de of
745 (rhs, de') -> evalI rhs de'
746 evalI (CasePrimI bndr expr alts def) de
747 = case helper_casePrim bndr expr alts def de of
748 (rhs, de') -> evalI rhs de'
750 -- evalI can't be applied to a lambda term, by defn, since those
753 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
754 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
756 --evalI (NonRec (IBind v e) b) de
757 -- = evalI b (augment de v (eval e de))
760 = error ("evalI: unhandled case: " ++ showExprTag other)
762 --------------------------------------------------------
763 --- Evaluator for things of Float# representation
764 --------------------------------------------------------
766 -- Evaluate something which has an unboxed Int rep
767 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
770 -- | trace ("evalF: " ++ showExprTag expr) False
771 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
772 = error "evalF: ?!?!"
774 evalF (LitF f#) de = f#
777 case lookupUFM de v of
778 Just e -> case unsafeCoerce# e of F# i -> i
779 Nothing -> error ("evalF: lookupUFM " ++ show v)
781 -- Deal with application of a function returning an Int# rep
782 -- to arguments of any persuasion. Note that the function itself
783 -- always has pointer rep.
784 evalF (AppIF e1 e2) de
785 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
786 evalF (AppPF e1 e2) de
787 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
788 evalF (AppFF e1 e2) de
789 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
790 evalF (AppDF e1 e2) de
791 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
793 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
794 -- except in the sense that we go on and evaluate the body with whichever
795 -- evaluator was used for the expression as a whole.
796 evalF (NonRecF bind b) de
797 = evalF b (augment_nonrec bind de)
798 evalF (RecF binds b) de
799 = evalF b (augment_rec binds de)
800 evalF (CaseAlgF bndr expr alts def) de
801 = case helper_caseAlg bndr expr alts def de of
802 (rhs, de') -> evalF rhs de'
803 evalF (CasePrimF bndr expr alts def) de
804 = case helper_casePrim bndr expr alts def de of
805 (rhs, de') -> evalF rhs de'
807 -- evalF can't be applied to a lambda term, by defn, since those
810 evalF (PrimOpF op _) de
811 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
814 = error ("evalF: unhandled case: " ++ showExprTag other)
816 --------------------------------------------------------
817 --- Evaluator for things of Double# representation
818 --------------------------------------------------------
820 -- Evaluate something which has an unboxed Int rep
821 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
824 -- | trace ("evalD: " ++ showExprTag expr) False
825 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
826 = error "evalD: ?!?!"
828 evalD (LitD d#) de = d#
831 case lookupUFM de v of
832 Just e -> case unsafeCoerce# e of D# i -> i
833 Nothing -> error ("evalD: lookupUFM " ++ show v)
835 -- Deal with application of a function returning an Int# rep
836 -- to arguments of any persuasion. Note that the function itself
837 -- always has pointer rep.
838 evalD (AppID e1 e2) de
839 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
840 evalD (AppPD e1 e2) de
841 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
842 evalD (AppFD e1 e2) de
843 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
844 evalD (AppDD e1 e2) de
845 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
847 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
848 -- except in the sense that we go on and evaluate the body with whichever
849 -- evaluator was used for the expression as a whole.
850 evalD (NonRecD bind b) de
851 = evalD b (augment_nonrec bind de)
852 evalD (RecD binds b) de
853 = evalD b (augment_rec binds de)
854 evalD (CaseAlgD bndr expr alts def) de
855 = case helper_caseAlg bndr expr alts def de of
856 (rhs, de') -> evalD rhs de'
857 evalD (CasePrimD bndr expr alts def) de
858 = case helper_casePrim bndr expr alts def de of
859 (rhs, de') -> evalD rhs de'
861 -- evalD can't be applied to a lambda term, by defn, since those
864 evalD (PrimOpD op _) de
865 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
868 = error ("evalD: unhandled case: " ++ showExprTag other)
870 --------------------------------------------------------
871 --- Helper bits and pieces
872 --------------------------------------------------------
874 -- Find the Rep of any Expr
875 repOf :: LinkedIExpr -> Rep
877 repOf (LamPP _ _) = RepP
878 repOf (LamPI _ _) = RepP
879 repOf (LamPF _ _) = RepP
880 repOf (LamPD _ _) = RepP
881 repOf (LamIP _ _) = RepP
882 repOf (LamII _ _) = RepP
883 repOf (LamIF _ _) = RepP
884 repOf (LamID _ _) = RepP
885 repOf (LamFP _ _) = RepP
886 repOf (LamFI _ _) = RepP
887 repOf (LamFF _ _) = RepP
888 repOf (LamFD _ _) = RepP
889 repOf (LamDP _ _) = RepP
890 repOf (LamDI _ _) = RepP
891 repOf (LamDF _ _) = RepP
892 repOf (LamDD _ _) = RepP
894 repOf (AppPP _ _) = RepP
895 repOf (AppPI _ _) = RepI
896 repOf (AppPF _ _) = RepF
897 repOf (AppPD _ _) = RepD
898 repOf (AppIP _ _) = RepP
899 repOf (AppII _ _) = RepI
900 repOf (AppIF _ _) = RepF
901 repOf (AppID _ _) = RepD
902 repOf (AppFP _ _) = RepP
903 repOf (AppFI _ _) = RepI
904 repOf (AppFF _ _) = RepF
905 repOf (AppFD _ _) = RepD
906 repOf (AppDP _ _) = RepP
907 repOf (AppDI _ _) = RepI
908 repOf (AppDF _ _) = RepF
909 repOf (AppDD _ _) = RepD
911 repOf (NonRecP _ _) = RepP
912 repOf (NonRecI _ _) = RepI
913 repOf (NonRecF _ _) = RepF
914 repOf (NonRecD _ _) = RepD
916 repOf (LitI _) = RepI
917 repOf (LitF _) = RepF
918 repOf (LitD _) = RepD
920 repOf (VarP _) = RepI
921 repOf (VarI _) = RepI
922 repOf (VarF _) = RepF
923 repOf (VarD _) = RepD
925 repOf (PrimOpP _ _) = RepP
926 repOf (PrimOpI _ _) = RepI
927 repOf (PrimOpF _ _) = RepF
928 repOf (PrimOpD _ _) = RepD
930 repOf (ConApp _) = RepP
931 repOf (ConAppI _ _) = RepP
932 repOf (ConAppP _ _) = RepP
933 repOf (ConAppPP _ _ _) = RepP
934 repOf (ConAppPPP _ _ _ _) = RepP
936 repOf (CaseAlgP _ _ _ _) = RepP
937 repOf (CaseAlgI _ _ _ _) = RepI
938 repOf (CaseAlgF _ _ _ _) = RepF
939 repOf (CaseAlgD _ _ _ _) = RepD
941 repOf (CasePrimP _ _ _ _) = RepP
942 repOf (CasePrimI _ _ _ _) = RepI
943 repOf (CasePrimF _ _ _ _) = RepF
944 repOf (CasePrimD _ _ _ _) = RepD
947 = error ("repOf: unhandled case: " ++ showExprTag other)
949 -- how big (in words) is one of these
950 repSizeW :: Rep -> Int
955 -- Evaluate an expression, using the appropriate evaluator,
956 -- then box up the result. Note that it's only safe to use this
957 -- to create values to put in the environment. You can't use it
958 -- to create a value which might get passed to native code since that
959 -- code will have no idea that unboxed things have been boxed.
960 eval :: LinkedIExpr -> UniqFM boxed -> boxed
963 RepI -> unsafeCoerce# (I# (evalI expr de))
964 RepP -> evalP expr de
965 RepF -> unsafeCoerce# (F# (evalF expr de))
966 RepD -> unsafeCoerce# (D# (evalD expr de))
968 -- Evaluate the scrutinee of a case, select an alternative,
969 -- augment the environment appropriately, and return the alt
970 -- and the augmented environment.
971 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
973 -> (LinkedIExpr, UniqFM boxed)
974 helper_caseAlg bndr expr alts def de
975 = let exprEv = evalP expr de
977 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
978 case select_altAlg (tagOf exprEv) alts def of
979 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
982 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
984 -> (LinkedIExpr, UniqFM boxed)
985 helper_casePrim bndr expr alts def de
987 -- Umm, can expr have any other rep? Yes ...
988 -- CharRep, DoubleRep, FloatRep. What about string reps?
989 RepI -> case evalI expr de of
990 i# -> (select_altPrim alts def (LitI i#),
991 addToUFM de bndr (unsafeCoerce# (I# i#)))
994 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
995 augment_from_constr de con ([],offset)
997 augment_from_constr de con ((v,rep):vs,offset)
1000 RepP -> indexPtrOffClosure con offset
1001 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1003 augment_from_constr (addToUFM de v v_binding) con
1004 (vs,offset + repSizeW rep)
1006 -- Augment the environment for a non-recursive let.
1007 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1008 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1010 -- Augment the environment for a recursive let.
1011 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1012 augment_rec binds de
1013 = let vars = map binder binds
1014 rhss = map bindee binds
1015 rhs_vs = map (\rhs -> eval rhs de') rhss
1016 de' = addListToUFM de (zip vars rhs_vs)
1020 -- a must be a constructor?
1022 tagOf x = I# (dataToTag# x)
1024 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1025 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1026 select_altAlg tag [] (Just def) = ([],def)
1027 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1030 else select_altAlg tag alts def
1032 -- literal may only be a literal, not an arbitrary expression
1033 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1034 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1035 select_altPrim [] (Just def) literal = def
1036 select_altPrim ((AltPrim lit rhs):alts) def literal
1037 = if eqLits lit literal
1039 else select_altPrim alts def literal
1041 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1044 -- a is a constructor
1045 indexPtrOffClosure :: a -> Int -> b
1046 indexPtrOffClosure con (I# offset)
1047 = case indexPtrOffClosure# con offset of (# x #) -> x
1049 indexIntOffClosure :: a -> Int -> Int#
1050 indexIntOffClosure con (I# offset)
1051 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1054 ------------------------------------------------------------------------
1055 --- Manufacturing of info tables for DataCons defined in this module ---
1056 ------------------------------------------------------------------------
1058 -- Make info tables for the data decls in this module
1059 mkITbls :: [TyCon] -> IO ItblEnv
1060 mkITbls [] = return emptyFM
1061 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1062 itbls2 <- mkITbls tcs
1063 return (itbls `plusFM` itbls2)
1065 mkITbl :: TyCon -> IO ItblEnv
1067 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1069 | not (isDataTyCon tc)
1071 | n == length dcs -- paranoia; this is an assertion.
1072 = make_constr_itbls dcs
1074 dcs = tyConDataCons tc
1075 n = tyConFamilySize tc
1078 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1080 -- Assumes constructors are numbered from zero, not one
1081 make_constr_itbls :: [DataCon] -> IO ItblEnv
1082 make_constr_itbls cons
1084 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1085 return (listToFM is)
1087 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1088 return (listToFM is)
1090 mk_vecret_itbl (dcon, conNo)
1091 = mk_itbl dcon conNo (vecret_entry conNo)
1092 mk_dirret_itbl (dcon, conNo)
1093 = mk_itbl dcon conNo mci_constr_entry
1095 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1096 mk_itbl dcon conNo entry_addr
1097 = let (tot_wds, ptr_wds, _)
1098 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1100 nptrs = tot_wds - ptr_wds
1101 itbl = StgInfoTable {
1102 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1103 tipe = fromIntegral cONSTR,
1104 srtlen = fromIntegral conNo,
1105 code0 = fromIntegral code0, code1 = fromIntegral code1,
1106 code2 = fromIntegral code2, code3 = fromIntegral code3,
1107 code4 = fromIntegral code4, code5 = fromIntegral code5,
1108 code6 = fromIntegral code6, code7 = fromIntegral code7
1110 -- Make a piece of code to jump to "entry_label".
1111 -- This is the only arch-dependent bit.
1112 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1113 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1115 -- B8 ZZ YY XX WW FF E0
1116 (code0,code1,code2,code3,code4,code5,code6,code7)
1117 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1118 byte 2 entry_addr_w, byte 3 entry_addr_w,
1122 entry_addr_w :: Word32
1123 entry_addr_w = fromIntegral (addrToInt entry_addr)
1125 do addr <- mallocElem itbl
1126 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1127 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1128 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1130 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1133 byte :: Int -> Word32 -> Word32
1134 byte 0 w = w .&. 0xFF
1135 byte 1 w = (w `shiftR` 8) .&. 0xFF
1136 byte 2 w = (w `shiftR` 16) .&. 0xFF
1137 byte 3 w = (w `shiftR` 24) .&. 0xFF
1140 vecret_entry 0 = mci_constr1_entry
1141 vecret_entry 1 = mci_constr2_entry
1142 vecret_entry 2 = mci_constr3_entry
1143 vecret_entry 3 = mci_constr4_entry
1144 vecret_entry 4 = mci_constr5_entry
1145 vecret_entry 5 = mci_constr6_entry
1146 vecret_entry 6 = mci_constr7_entry
1147 vecret_entry 7 = mci_constr8_entry
1149 -- entry point for direct returns for created constr itbls
1150 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1151 -- and the 8 vectored ones
1152 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1153 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1154 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1155 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1156 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1157 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1158 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1159 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1163 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1166 -- Ultra-minimalist version specially for constructors
1167 data StgInfoTable = StgInfoTable {
1172 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1176 instance Storable StgInfoTable where
1179 = (sum . map (\f -> f itbl))
1180 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1181 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1182 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1185 = (sum . map (\f -> f itbl))
1186 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1187 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1188 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1191 = do a1 <- store (ptrs itbl) a0
1192 a2 <- store (nptrs itbl) a1
1193 a3 <- store (tipe itbl) a2
1194 a4 <- store (srtlen itbl) a3
1195 a5 <- store (code0 itbl) a4
1196 a6 <- store (code1 itbl) a5
1197 a7 <- store (code2 itbl) a6
1198 a8 <- store (code3 itbl) a7
1199 a9 <- store (code4 itbl) a8
1200 aA <- store (code5 itbl) a9
1201 aB <- store (code6 itbl) aA
1202 aC <- store (code7 itbl) aB
1206 = do (a1,ptrs) <- load a0
1207 (a2,nptrs) <- load a1
1208 (a3,tipe) <- load a2
1209 (a4,srtlen) <- load a3
1210 (a5,code0) <- load a4
1211 (a6,code1) <- load a5
1212 (a7,code2) <- load a6
1213 (a8,code3) <- load a7
1214 (a9,code4) <- load a8
1215 (aA,code5) <- load a9
1216 (aB,code6) <- load aA
1217 (aC,code7) <- load aB
1218 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1219 srtlen = srtlen, tipe = tipe,
1220 code0 = code0, code1 = code1, code2 = code2,
1221 code3 = code3, code4 = code4, code5 = code5,
1222 code6 = code6, code7 = code7 }
1224 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1225 fieldSz sel x = sizeOf (sel x)
1227 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1228 fieldAl sel x = alignment (sel x)
1230 store :: Storable a => a -> Addr -> IO Addr
1231 store x addr = do poke addr x
1232 return (addr `plusAddr` fromIntegral (sizeOf x))
1234 load :: Storable a => Addr -> IO (Addr, a)
1235 load addr = do x <- peek addr
1236 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1238 -----------------------------------------------------------------------------q
1240 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1242 #endif /* #if __GLASGOW_HASKELL__ <= 408 */