2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
11 filterRdrNameEnv, -- :: [ModuleName] -> FiniteMap RdrName a
12 -- -> FiniteMap RdrName a
14 linkIModules, -- :: ItblEnv -> ClosureEnv
15 -- -> [([UnlinkedIBind], ItblEnv)]
16 -- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
18 iExprToHValue, -- :: ItblEnv -> ClosureEnv
19 -- -> UnlinkedIExpr -> HValue
21 stgBindsToInterpSyn,-- :: [StgBinding]
22 -- -> [TyCon] -> [Class]
23 -- -> IO ([UnlinkedIBind], ItblEnv)
25 stgExprToInterpSyn, -- :: StgExpr
26 -- -> IO UnlinkedIExpr
28 interp -- :: LinkedIExpr -> HValue
31 {- -----------------------------------------------------------------------------
34 - link should be in the IO monad, so it can modify the symtabs as it
37 - need a way to remove the bindings for a module from the symtabs.
38 maybe the symtabs should be indexed by module first.
40 - change the representation to something less verbose (?).
42 - converting string literals to Addr# is horrible and introduces
43 a memory leak. See if something can be done about this.
45 ----------------------------------------------------------------------------- -}
47 #include "HsVersions.h"
50 import Id ( Id, idPrimRep )
53 import PrimOp ( PrimOp(..) )
54 import PrimRep ( PrimRep(..) )
55 import Literal ( Literal(..) )
56 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
57 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
58 import ClosureInfo ( mkVirtHeapOffsets )
59 import Module ( ModuleName )
60 import Name ( toRdrName )
64 import {-# SOURCE #-} MCI_make_constr
66 import IOExts ( unsafePerformIO ) -- ToDo: remove
67 import PrelGHC --( unsafeCoerce#, dataToTag#,
68 -- indexPtrOffClosure#, indexWordOffClosure# )
69 import PrelAddr ( Addr(..) )
70 import PrelFloat ( Float(..), Double(..) )
73 import GlaExts ( Int(..) )
74 import Module ( moduleNameFS )
76 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
77 import Class ( Class, classTyCon )
81 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
83 import Panic ( panic )
84 import OccName ( occNameString )
85 import ErrUtils ( showPass, dumpIfSet_dyn )
86 import CmdLineOpts ( DynFlags, DynFlag(..) )
92 -- ---------------------------------------------------------------------------
93 -- Environments needed by the linker
94 -- ---------------------------------------------------------------------------
96 type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable)
97 type ClosureEnv = FiniteMap RdrName HValue
98 emptyClosureEnv = emptyFM
100 -- remove all entries for a given set of modules from the environment
101 filterRdrNameEnv :: [ModuleName] -> FiniteMap RdrName a -> FiniteMap RdrName a
102 filterRdrNameEnv mods env
103 = filterFM (\n _ -> rdrNameModule n `notElem` mods) env
105 -- ---------------------------------------------------------------------------
106 -- Turn an UnlinkedIExpr into a value we can run, for the interpreter
107 -- ---------------------------------------------------------------------------
109 iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
110 iExprToHValue ie ce expr = return (interp (linkIExpr ie ce expr))
112 -- ---------------------------------------------------------------------------
113 -- Convert STG to an unlinked interpretable
114 -- ---------------------------------------------------------------------------
116 -- visible from outside
117 stgBindsToInterpSyn :: DynFlags
119 -> [TyCon] -> [Class]
120 -> IO ([UnlinkedIBind], ItblEnv)
121 stgBindsToInterpSyn dflags binds local_tycons local_classes
122 = do showPass dflags "StgToInterp"
123 let ibinds = concatMap (translateBind emptyUniqSet) binds
124 let tycs = local_tycons ++ map classTyCon local_classes
125 dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
126 "Convert To InterpSyn" (vcat (map pprIBind ibinds))
127 itblenv <- mkITbls tycs
128 return (ibinds, itblenv)
130 stgExprToInterpSyn :: DynFlags
133 stgExprToInterpSyn dflags expr
134 = do showPass dflags "StgToInterp"
135 let iexpr = stg2expr emptyUniqSet expr
136 dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
137 "Convert To InterpSyn" (pprIExpr iexpr)
140 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
141 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
142 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
143 where ie' = addListToUniqSet ie (map fst vs_n_es)
145 isRec (StgNonRec _ _) = False
146 isRec (StgRec _) = True
148 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
149 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
152 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
153 rhsRep = repOfStgExpr rhs
154 mkLambdas [] = rhsExpr
155 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
156 rhs2expr ie (StgRhsCon ccs dcon args)
157 = conapp2expr ie dcon args
159 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
160 conapp2expr ie dcon args
161 = mkConApp con_rdrname reps exprs
163 con_rdrname = toRdrName dcon
164 exprs = map (arg2expr ie) inHeapOrder
165 reps = map repOfArg inHeapOrder
166 inHeapOrder = toHeapOrder args
168 toHeapOrder :: [StgArg] -> [StgArg]
170 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
171 (rearranged, offsets) = unzip rearranged_w_offsets
175 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
177 -- Handle most common cases specially; do the rest with a generic
178 -- mechanism (deferred till later :)
179 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
180 mkConApp nm [] [] = ConApp nm
181 mkConApp nm [RepI] [a1] = ConAppI nm a1
182 mkConApp nm [RepP] [a1] = ConAppP nm a1
183 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
184 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
185 mkConApp nm reps args
186 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
188 mkLam RepP RepP = LamPP
189 mkLam RepI RepP = LamIP
190 mkLam RepP RepI = LamPI
191 mkLam RepI RepI = LamII
192 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
194 mkApp RepP RepP = AppPP
195 mkApp RepI RepP = AppIP
196 mkApp RepP RepI = AppPI
197 mkApp RepI RepI = AppII
198 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
201 repOfId = primRep2Rep . idPrimRep
206 -- genuine lifted types
209 -- all these are unboxed, fit into a word, and we assume they
210 -- all have the same call/return convention.
218 -- these are pretty dodgy: really pointers, but
219 -- we can't let the compiler build thunks with these reps.
220 ForeignObjRep -> RepP
221 StableNameRep -> RepP
229 other -> pprPanic "primRep2Rep" (ppr other)
231 repOfStgExpr :: StgExpr -> Rep
236 StgCase scrut live liveR bndr srt alts
237 -> case altRhss alts of
238 (a:_) -> repOfStgExpr a
239 [] -> panic "repOfStgExpr: no alts"
243 -> repOfApp ((deNoteType.repType.idType) var) (length args)
245 StgPrimApp op args res_ty
246 -> (primRep2Rep.typePrimRep) res_ty
248 StgLet binds body -> repOfStgExpr body
249 StgLetNoEscape live liveR binds body -> repOfStgExpr body
251 StgConApp con args -> RepP -- by definition
254 -> pprPanic "repOfStgExpr" (ppr other)
256 altRhss (StgAlgAlts tycon alts def)
257 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
258 altRhss (StgPrimAlts tycon alts def)
259 = [rhs | (lit,rhs) <- alts] ++ defRhs def
262 defRhs (StgBindDefault rhs)
265 -- returns the Rep of the result of applying ty to n args.
266 repOfApp :: Type -> Int -> Rep
267 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
268 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
280 MachStr _ -> RepI -- because it's a ptr outside the heap
281 other -> pprPanic "repOfLit" (ppr lit)
283 lit2expr :: Literal -> UnlinkedIExpr
286 MachInt i -> case fromIntegral i of I# i -> LitI i
287 MachWord i -> case fromIntegral i of I# i -> LitI i
288 MachAddr i -> case fromIntegral i of I# i -> LitI i
289 MachChar i -> case fromIntegral i of I# i -> LitI i
290 MachFloat f -> case fromRational f of F# f -> LitF f
291 MachDouble f -> case fromRational f of D# f -> LitD f
294 CharStr s i -> LitI (addr2Int# s)
297 -- sigh, a string in the heap is no good to us. We need a
298 -- static C pointer, since the type of a string literal is
299 -- Addr#. So, copy the string into C land and introduce a
300 -- memory leak at the same time.
302 -- CAREFUL! Chars are 32 bits in ghc 4.09+
303 case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
304 strncpy a ba (fromIntegral n)
305 writeCharOffAddr addr 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 tycon 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)
355 -- treat let-no-escape just like let.
356 StgLetNoEscape _ _ binds body
357 -> stg2expr ie (StgLet binds body)
360 -> pprPanic "stg2expr" (ppr stgexpr)
363 = AltPrim (lit2expr lit) (stg2expr ie rhs)
364 doAlgAlt (dcon,vars,uses,rhs)
365 = AltAlg (dataConTag dcon - 1)
366 (map id2VaaRep (toHeapOrder vars))
367 (stg2expr (addListToUniqSet ie vars) rhs)
370 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
371 (rearranged,offsets) = unzip rearranged_w_offsets
375 def2expr StgNoDefault = Nothing
376 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
378 mkAppChain ie result_rep so_far []
380 mkAppChain ie result_rep so_far [a]
381 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
382 mkAppChain ie result_rep so_far (a:as)
383 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
385 mkCasePrim RepI = CasePrimI
386 mkCasePrim RepP = CasePrimP
388 mkCaseAlg RepI = CaseAlgI
389 mkCaseAlg RepP = CaseAlgP
391 -- any var that isn't in scope is turned into a Native
393 | var `elementOfUniqSet` ie =
399 | otherwise = Native (toRdrName var)
403 mkNonRec RepI = NonRecI
404 mkNonRec RepP = NonRecP
406 mkPrimOp RepI = PrimOpI
407 mkPrimOp RepP = PrimOpP
409 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
410 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
411 arg2expr ie (StgLitArg lit) = lit2expr lit
412 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
414 repOfArg :: StgArg -> Rep
415 repOfArg (StgVarArg v) = repOfId v
416 repOfArg (StgLitArg lit) = repOfLit lit
417 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
419 id2VaaRep var = (var, repOfId var)
422 -- ---------------------------------------------------------------------------
423 -- Link interpretables into something we can run
424 -- ---------------------------------------------------------------------------
426 linkIModules :: ItblEnv -- incoming global itbl env; returned updated
427 -> ClosureEnv -- incoming global closure env; returned updated
428 -> [([UnlinkedIBind], ItblEnv)]
429 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
430 linkIModules gie gce mods = do
431 let (bindss, ies) = unzip mods
432 binds = concat bindss
433 top_level_binders = map (toRdrName.binder) binds
434 final_gie = foldr plusFM gie ies
437 new_gce = addListToFM gce (zip top_level_binders new_rhss)
438 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
439 --vvvvvvvvv----------------------------------------^^^^^^^^^-- circular
440 new_binds = linkIBinds final_gie new_gce binds
442 return (new_binds, final_gie, new_gce)
445 -- We're supposed to augment the environments with the values of any
446 -- external functions/info tables we need as we go along, but that's a
447 -- lot of hassle so for now I'll look up external things as they crop
448 -- up and not cache them in the source symbol tables. The interpreted
449 -- code will still be referenced in the source symbol tables.
451 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
452 linkIBinds ie ce binds = map (linkIBind ie ce) binds
454 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
456 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> LinkedIExpr
457 linkIExpr ie ce expr = case expr of
459 CaseAlgP bndr expr alts dflt ->
460 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
461 (linkDefault ie ce dflt)
463 CaseAlgI bndr expr alts dflt ->
464 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
465 (linkDefault ie ce dflt)
467 CasePrimP bndr expr alts dflt ->
468 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
469 (linkDefault ie ce dflt)
471 CasePrimI bndr expr alts dflt ->
472 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
473 (linkDefault ie ce dflt)
476 ConApp (lookupCon ie con)
479 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
482 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
484 ConAppPP con arg0 arg1 ->
485 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
487 ConAppPPP con arg0 arg1 arg2 ->
488 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
489 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
491 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
492 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
494 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
495 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
497 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
498 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
504 Native var -> lookupNative ce var
506 VarP v -> lookupVar ce VarP v
507 VarI v -> lookupVar ce VarI v
509 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
510 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
511 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
512 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
514 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
515 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
516 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
517 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
520 case lookupFM ie con of
521 Just (Ptr addr) -> addr
523 -- try looking up in the object files.
525 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
527 Nothing -> pprPanic "linkIExpr" (ppr con)
529 lookupNative ce var =
530 case lookupFM ce var of
533 -- try looking up in the object files.
534 let lbl = (rdrNameToCLabel var "closure")
535 addr = unsafePerformIO (lookupSymbol lbl) in
536 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
537 Just (A# addr) -> Native (unsafeCoerce# addr)
538 Nothing -> pprPanic "linkIExpr" (ppr var)
540 -- some VarI/VarP refer to top-level interpreted functions; we change
541 -- them into Natives here.
543 case lookupFM ce (toRdrName v) of
547 -- HACK!!! ToDo: cleaner
548 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
549 rdrNameToCLabel rn suffix =
550 _UNPK_(moduleNameFS (rdrNameModule rn))
551 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
553 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
554 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
556 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
557 linkPrimAlt ie ce (AltPrim lit rhs)
558 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
560 linkDefault ie ce Nothing = Nothing
561 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
563 -- ---------------------------------------------------------------------------
564 -- The interpreter proper
565 -- ---------------------------------------------------------------------------
567 -- The dynamic environment contains everything boxed.
568 -- eval* functions which look up values in it will know the
569 -- representation of the thing they are looking up, so they
570 -- can cast/unbox it as necessary.
572 -- ---------------------------------------------------------------------------
573 -- Evaluator for things of boxed (pointer) representation
574 -- ---------------------------------------------------------------------------
576 interp :: LinkedIExpr -> HValue
577 interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
579 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
583 -- | trace ("evalP: " ++ showExprTag expr) False
584 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
585 = error "evalP: ?!?!"
588 evalP (Native p) de = unsafeCoerce# p
590 -- First try the dynamic env. If that fails, assume it's a top-level
591 -- binding and look in the static env. That gives an Expr, which we
592 -- must convert to a boxed thingy by applying evalP to it. Because
593 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
594 -- CAFs), it's always safe to use evalP.
596 = case lookupUFM de v of
598 Nothing -> error ("evalP: lookupUFM " ++ show v)
600 -- Deal with application of a function returning a pointer rep
601 -- to arguments of any persuasion. Note that the function itself
602 -- always has pointer rep.
603 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
604 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
605 evalP (AppFP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de)
606 evalP (AppDP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de)
608 -- Lambdas always return P-rep, but we need to do different things
609 -- depending on both the argument and result representations.
611 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
613 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
615 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
617 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
619 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
621 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
623 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
625 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
627 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
629 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
631 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
633 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
635 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
637 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
639 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
641 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
644 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
645 -- except in the sense that we go on and evaluate the body with whichever
646 -- evaluator was used for the expression as a whole.
647 evalP (NonRecP bind e) de
648 = evalP e (augment_nonrec bind de)
649 evalP (RecP binds b) de
650 = evalP b (augment_rec binds de)
651 evalP (CaseAlgP bndr expr alts def) de
652 = case helper_caseAlg bndr expr alts def de of
653 (rhs, de') -> evalP rhs de'
654 evalP (CasePrimP bndr expr alts def) de
655 = case helper_casePrim bndr expr alts def de of
656 (rhs, de') -> evalP rhs de'
659 -- ConApp can only be handled by evalP
660 evalP (ConApp itbl args) se de
663 -- This appalling hack suggested (gleefully) by SDM
664 -- It is not well typed (needless to say?)
665 loop :: [Expr] -> boxed
667 = trace "loop-empty" (
668 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
671 = trace "loop-not-empty" (
673 RepI -> case evalI a de of i# -> loop as i#
674 RepP -> let p = evalP a de in loop as p
678 evalP (ConAppI (A# itbl) a1) de
679 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
681 evalP (ConApp (A# itbl)) de
682 = mci_make_constr itbl
684 evalP (ConAppP (A# itbl) a1) de
685 = let p1 = evalP a1 de
686 in mci_make_constrP itbl p1
688 evalP (ConAppPP (A# itbl) a1 a2) de
689 = let p1 = evalP a1 de
691 in mci_make_constrPP itbl p1 p2
693 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
694 = let p1 = evalP a1 de
697 in mci_make_constrPPP itbl p1 p2 p3
702 = error ("evalP: unhandled case: " ++ showExprTag other)
704 --------------------------------------------------------
705 --- Evaluator for things of Int# representation
706 --------------------------------------------------------
708 -- Evaluate something which has an unboxed Int rep
709 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
713 -- | trace ("evalI: " ++ showExprTag expr) False
714 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
715 = error "evalI: ?!?!"
718 evalI (LitI i#) de = i#
721 case lookupUFM de v of
722 Just e -> case unsafeCoerce# e of I# i -> i
723 Nothing -> error ("evalI: lookupUFM " ++ show v)
725 -- Deal with application of a function returning an Int# rep
726 -- to arguments of any persuasion. Note that the function itself
727 -- always has pointer rep.
728 evalI (AppII e1 e2) de
729 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
730 evalI (AppPI e1 e2) de
731 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
732 evalI (AppFI e1 e2) de
733 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
734 evalI (AppDI e1 e2) de
735 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
737 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
738 -- except in the sense that we go on and evaluate the body with whichever
739 -- evaluator was used for the expression as a whole.
740 evalI (NonRecI bind b) de
741 = evalI b (augment_nonrec bind de)
742 evalI (RecI binds b) de
743 = evalI b (augment_rec binds de)
744 evalI (CaseAlgI bndr expr alts def) de
745 = case helper_caseAlg bndr expr alts def de of
746 (rhs, de') -> evalI rhs de'
747 evalI (CasePrimI bndr expr alts def) de
748 = case helper_casePrim bndr expr alts def de of
749 (rhs, de') -> evalI rhs de'
751 -- evalI can't be applied to a lambda term, by defn, since those
754 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
755 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
757 --evalI (NonRec (IBind v e) b) de
758 -- = evalI b (augment de v (eval e de))
761 = error ("evalI: unhandled case: " ++ showExprTag other)
763 --------------------------------------------------------
764 --- Evaluator for things of Float# representation
765 --------------------------------------------------------
767 -- Evaluate something which has an unboxed Int rep
768 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
772 -- | trace ("evalF: " ++ showExprTag expr) False
773 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
774 = error "evalF: ?!?!"
777 evalF (LitF f#) de = f#
780 case lookupUFM de v of
781 Just e -> case unsafeCoerce# e of F# i -> i
782 Nothing -> error ("evalF: lookupUFM " ++ show v)
784 -- Deal with application of a function returning an Int# rep
785 -- to arguments of any persuasion. Note that the function itself
786 -- always has pointer rep.
787 evalF (AppIF e1 e2) de
788 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
789 evalF (AppPF e1 e2) de
790 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
791 evalF (AppFF e1 e2) de
792 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
793 evalF (AppDF e1 e2) de
794 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
796 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
797 -- except in the sense that we go on and evaluate the body with whichever
798 -- evaluator was used for the expression as a whole.
799 evalF (NonRecF bind b) de
800 = evalF b (augment_nonrec bind de)
801 evalF (RecF binds b) de
802 = evalF b (augment_rec binds de)
803 evalF (CaseAlgF bndr expr alts def) de
804 = case helper_caseAlg bndr expr alts def de of
805 (rhs, de') -> evalF rhs de'
806 evalF (CasePrimF bndr expr alts def) de
807 = case helper_casePrim bndr expr alts def de of
808 (rhs, de') -> evalF rhs de'
810 -- evalF can't be applied to a lambda term, by defn, since those
813 evalF (PrimOpF op _) de
814 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
817 = error ("evalF: unhandled case: " ++ showExprTag other)
819 --------------------------------------------------------
820 --- Evaluator for things of Double# representation
821 --------------------------------------------------------
823 -- Evaluate something which has an unboxed Int rep
824 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
828 -- | trace ("evalD: " ++ showExprTag expr) False
829 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
830 = error "evalD: ?!?!"
833 evalD (LitD d#) de = d#
836 case lookupUFM de v of
837 Just e -> case unsafeCoerce# e of D# i -> i
838 Nothing -> error ("evalD: lookupUFM " ++ show v)
840 -- Deal with application of a function returning an Int# rep
841 -- to arguments of any persuasion. Note that the function itself
842 -- always has pointer rep.
843 evalD (AppID e1 e2) de
844 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
845 evalD (AppPD e1 e2) de
846 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
847 evalD (AppFD e1 e2) de
848 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
849 evalD (AppDD e1 e2) de
850 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
852 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
853 -- except in the sense that we go on and evaluate the body with whichever
854 -- evaluator was used for the expression as a whole.
855 evalD (NonRecD bind b) de
856 = evalD b (augment_nonrec bind de)
857 evalD (RecD binds b) de
858 = evalD b (augment_rec binds de)
859 evalD (CaseAlgD bndr expr alts def) de
860 = case helper_caseAlg bndr expr alts def de of
861 (rhs, de') -> evalD rhs de'
862 evalD (CasePrimD bndr expr alts def) de
863 = case helper_casePrim bndr expr alts def de of
864 (rhs, de') -> evalD rhs de'
866 -- evalD can't be applied to a lambda term, by defn, since those
869 evalD (PrimOpD op _) de
870 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
873 = error ("evalD: unhandled case: " ++ showExprTag other)
875 --------------------------------------------------------
876 --- Helper bits and pieces
877 --------------------------------------------------------
879 -- Find the Rep of any Expr
880 repOf :: LinkedIExpr -> Rep
882 repOf (LamPP _ _) = RepP
883 repOf (LamPI _ _) = RepP
884 repOf (LamPF _ _) = RepP
885 repOf (LamPD _ _) = RepP
886 repOf (LamIP _ _) = RepP
887 repOf (LamII _ _) = RepP
888 repOf (LamIF _ _) = RepP
889 repOf (LamID _ _) = RepP
890 repOf (LamFP _ _) = RepP
891 repOf (LamFI _ _) = RepP
892 repOf (LamFF _ _) = RepP
893 repOf (LamFD _ _) = RepP
894 repOf (LamDP _ _) = RepP
895 repOf (LamDI _ _) = RepP
896 repOf (LamDF _ _) = RepP
897 repOf (LamDD _ _) = RepP
899 repOf (AppPP _ _) = RepP
900 repOf (AppPI _ _) = RepI
901 repOf (AppPF _ _) = RepF
902 repOf (AppPD _ _) = RepD
903 repOf (AppIP _ _) = RepP
904 repOf (AppII _ _) = RepI
905 repOf (AppIF _ _) = RepF
906 repOf (AppID _ _) = RepD
907 repOf (AppFP _ _) = RepP
908 repOf (AppFI _ _) = RepI
909 repOf (AppFF _ _) = RepF
910 repOf (AppFD _ _) = RepD
911 repOf (AppDP _ _) = RepP
912 repOf (AppDI _ _) = RepI
913 repOf (AppDF _ _) = RepF
914 repOf (AppDD _ _) = RepD
916 repOf (NonRecP _ _) = RepP
917 repOf (NonRecI _ _) = RepI
918 repOf (NonRecF _ _) = RepF
919 repOf (NonRecD _ _) = RepD
921 repOf (RecP _ _) = RepP
922 repOf (RecI _ _) = RepI
923 repOf (RecF _ _) = RepF
924 repOf (RecD _ _) = RepD
926 repOf (LitI _) = RepI
927 repOf (LitF _) = RepF
928 repOf (LitD _) = RepD
930 repOf (Native _) = RepP
932 repOf (VarP _) = RepP
933 repOf (VarI _) = RepI
934 repOf (VarF _) = RepF
935 repOf (VarD _) = RepD
937 repOf (PrimOpP _ _) = RepP
938 repOf (PrimOpI _ _) = RepI
939 repOf (PrimOpF _ _) = RepF
940 repOf (PrimOpD _ _) = RepD
942 repOf (ConApp _) = RepP
943 repOf (ConAppI _ _) = RepP
944 repOf (ConAppP _ _) = RepP
945 repOf (ConAppPP _ _ _) = RepP
946 repOf (ConAppPPP _ _ _ _) = RepP
948 repOf (CaseAlgP _ _ _ _) = RepP
949 repOf (CaseAlgI _ _ _ _) = RepI
950 repOf (CaseAlgF _ _ _ _) = RepF
951 repOf (CaseAlgD _ _ _ _) = RepD
953 repOf (CasePrimP _ _ _ _) = RepP
954 repOf (CasePrimI _ _ _ _) = RepI
955 repOf (CasePrimF _ _ _ _) = RepF
956 repOf (CasePrimD _ _ _ _) = RepD
959 = error ("repOf: unhandled case: " ++ showExprTag other)
961 -- how big (in words) is one of these
962 repSizeW :: Rep -> Int
967 -- Evaluate an expression, using the appropriate evaluator,
968 -- then box up the result. Note that it's only safe to use this
969 -- to create values to put in the environment. You can't use it
970 -- to create a value which might get passed to native code since that
971 -- code will have no idea that unboxed things have been boxed.
972 eval :: LinkedIExpr -> UniqFM boxed -> boxed
975 RepI -> unsafeCoerce# (I# (evalI expr de))
976 RepP -> evalP expr de
977 RepF -> unsafeCoerce# (F# (evalF expr de))
978 RepD -> unsafeCoerce# (D# (evalD expr de))
980 -- Evaluate the scrutinee of a case, select an alternative,
981 -- augment the environment appropriately, and return the alt
982 -- and the augmented environment.
983 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
985 -> (LinkedIExpr, UniqFM boxed)
986 helper_caseAlg bndr expr alts def de
987 = let exprEv = evalP expr de
989 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
990 case select_altAlg (tagOf exprEv) alts def of
991 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
994 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
996 -> (LinkedIExpr, UniqFM boxed)
997 helper_casePrim bndr expr alts def de
999 -- Umm, can expr have any other rep? Yes ...
1000 -- CharRep, DoubleRep, FloatRep. What about string reps?
1001 RepI -> case evalI expr de of
1002 i# -> (select_altPrim alts def (LitI i#),
1003 addToUFM de bndr (unsafeCoerce# (I# i#)))
1006 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1007 augment_from_constr de con ([],offset)
1009 augment_from_constr de con ((v,rep):vs,offset)
1012 RepP -> indexPtrOffClosure con offset
1013 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1015 augment_from_constr (addToUFM de v v_binding) con
1016 (vs,offset + repSizeW rep)
1018 -- Augment the environment for a non-recursive let.
1019 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1020 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1022 -- Augment the environment for a recursive let.
1023 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1024 augment_rec binds de
1025 = let vars = map binder binds
1026 rhss = map bindee binds
1027 rhs_vs = map (\rhs -> eval rhs de') rhss
1028 de' = addListToUFM de (zip vars rhs_vs)
1032 -- a must be a constructor?
1034 tagOf x = I# (dataToTag# x)
1036 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1037 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1038 select_altAlg tag [] (Just def) = ([],def)
1039 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1042 else select_altAlg tag alts def
1044 -- literal may only be a literal, not an arbitrary expression
1045 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1046 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1047 select_altPrim [] (Just def) literal = def
1048 select_altPrim ((AltPrim lit rhs):alts) def literal
1049 = if eqLits lit literal
1051 else select_altPrim alts def literal
1053 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1056 -- a is a constructor
1057 indexPtrOffClosure :: a -> Int -> b
1058 indexPtrOffClosure con (I# offset)
1059 = case indexPtrOffClosure# con offset of (# x #) -> x
1061 indexIntOffClosure :: a -> Int -> Int#
1062 indexIntOffClosure con (I# offset)
1063 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1066 ------------------------------------------------------------------------
1067 --- Manufacturing of info tables for DataCons defined in this module ---
1068 ------------------------------------------------------------------------
1070 #if __GLASGOW_HASKELL__ <= 408
1073 type ItblPtr = Ptr StgInfoTable
1076 -- Make info tables for the data decls in this module
1077 mkITbls :: [TyCon] -> IO ItblEnv
1078 mkITbls [] = return emptyFM
1079 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1080 itbls2 <- mkITbls tcs
1081 return (itbls `plusFM` itbls2)
1083 mkITbl :: TyCon -> IO ItblEnv
1085 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1087 | not (isDataTyCon tc)
1089 | n == length dcs -- paranoia; this is an assertion.
1090 = make_constr_itbls dcs
1092 dcs = tyConDataCons tc
1093 n = tyConFamilySize tc
1096 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1098 -- Assumes constructors are numbered from zero, not one
1099 make_constr_itbls :: [DataCon] -> IO ItblEnv
1100 make_constr_itbls cons
1102 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1103 return (listToFM is)
1105 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1106 return (listToFM is)
1108 mk_vecret_itbl (dcon, conNo)
1109 = mk_itbl dcon conNo (vecret_entry conNo)
1110 mk_dirret_itbl (dcon, conNo)
1111 = mk_itbl dcon conNo mci_constr_entry
1113 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
1114 mk_itbl dcon conNo entry_addr
1115 = let (tot_wds, ptr_wds, _)
1116 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1118 nptrs = tot_wds - ptr_wds
1119 itbl = StgInfoTable {
1120 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1121 tipe = fromIntegral cONSTR,
1122 srtlen = fromIntegral conNo,
1123 code0 = fromIntegral code0, code1 = fromIntegral code1,
1124 code2 = fromIntegral code2, code3 = fromIntegral code3,
1125 code4 = fromIntegral code4, code5 = fromIntegral code5,
1126 code6 = fromIntegral code6, code7 = fromIntegral code7
1128 -- Make a piece of code to jump to "entry_label".
1129 -- This is the only arch-dependent bit.
1130 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1131 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1133 -- B8 ZZ YY XX WW FF E0
1134 (code0,code1,code2,code3,code4,code5,code6,code7)
1135 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1136 byte 2 entry_addr_w, byte 3 entry_addr_w,
1140 entry_addr_w :: Word32
1141 entry_addr_w = fromIntegral (addrToInt entry_addr)
1144 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1145 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1146 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1148 return (toRdrName dcon, addr `plusPtr` 8)
1151 byte :: Int -> Word32 -> Word32
1152 byte 0 w = w .&. 0xFF
1153 byte 1 w = (w `shiftR` 8) .&. 0xFF
1154 byte 2 w = (w `shiftR` 16) .&. 0xFF
1155 byte 3 w = (w `shiftR` 24) .&. 0xFF
1158 vecret_entry 0 = mci_constr1_entry
1159 vecret_entry 1 = mci_constr2_entry
1160 vecret_entry 2 = mci_constr3_entry
1161 vecret_entry 3 = mci_constr4_entry
1162 vecret_entry 4 = mci_constr5_entry
1163 vecret_entry 5 = mci_constr6_entry
1164 vecret_entry 6 = mci_constr7_entry
1165 vecret_entry 7 = mci_constr8_entry
1167 -- entry point for direct returns for created constr itbls
1168 foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1169 -- and the 8 vectored ones
1170 foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
1171 foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
1172 foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
1173 foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
1174 foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
1175 foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
1176 foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
1177 foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1181 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1184 -- Ultra-minimalist version specially for constructors
1185 data StgInfoTable = StgInfoTable {
1190 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1194 instance Storable StgInfoTable where
1197 = (sum . map (\f -> f itbl))
1198 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1199 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1200 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1203 = (sum . map (\f -> f itbl))
1204 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1205 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1206 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1209 = do a1 <- store (ptrs itbl) (castPtr a0)
1210 a2 <- store (nptrs itbl) a1
1211 a3 <- store (tipe itbl) a2
1212 a4 <- store (srtlen itbl) a3
1213 a5 <- store (code0 itbl) a4
1214 a6 <- store (code1 itbl) a5
1215 a7 <- store (code2 itbl) a6
1216 a8 <- store (code3 itbl) a7
1217 a9 <- store (code4 itbl) a8
1218 aA <- store (code5 itbl) a9
1219 aB <- store (code6 itbl) aA
1220 aC <- store (code7 itbl) aB
1224 = do (a1,ptrs) <- load (castPtr a0)
1225 (a2,nptrs) <- load a1
1226 (a3,tipe) <- load a2
1227 (a4,srtlen) <- load a3
1228 (a5,code0) <- load a4
1229 (a6,code1) <- load a5
1230 (a7,code2) <- load a6
1231 (a8,code3) <- load a7
1232 (a9,code4) <- load a8
1233 (aA,code5) <- load a9
1234 (aB,code6) <- load aA
1235 (aC,code7) <- load aB
1236 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1237 srtlen = srtlen, tipe = tipe,
1238 code0 = code0, code1 = code1, code2 = code2,
1239 code3 = code3, code4 = code4, code5 = code5,
1240 code6 = code6, code7 = code7 }
1242 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1243 fieldSz sel x = sizeOf (sel x)
1245 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1246 fieldAl sel x = alignment (sel x)
1248 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1249 store x addr = do poke addr x
1250 return (castPtr (addr `plusPtr` sizeOf x))
1252 load :: Storable a => Ptr a -> IO (Ptr b, a)
1253 load addr = do x <- peek addr
1254 return (castPtr (addr `plusPtr` sizeOf x), x)
1256 -----------------------------------------------------------------------------q
1258 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()