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 )
86 import CmdLineOpts ( DynFlags )
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 itblenv <- mkITbls tycs
126 return (ibinds, itblenv)
128 stgExprToInterpSyn :: DynFlags
131 stgExprToInterpSyn dflags expr
132 = do showPass dflags "StgToInterp"
133 return (stg2expr emptyUniqSet expr)
135 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
136 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
137 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
138 where ie' = addListToUniqSet ie (map fst vs_n_es)
140 isRec (StgNonRec _ _) = False
141 isRec (StgRec _) = True
143 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
144 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
147 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
148 rhsRep = repOfStgExpr rhs
149 mkLambdas [] = rhsExpr
150 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
151 rhs2expr ie (StgRhsCon ccs dcon args)
152 = conapp2expr ie dcon args
154 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
155 conapp2expr ie dcon args
156 = mkConApp con_rdrname reps exprs
158 con_rdrname = toRdrName dcon
159 exprs = map (arg2expr ie) inHeapOrder
160 reps = map repOfArg inHeapOrder
161 inHeapOrder = toHeapOrder args
163 toHeapOrder :: [StgArg] -> [StgArg]
165 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
166 (rearranged, offsets) = unzip rearranged_w_offsets
170 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
172 -- Handle most common cases specially; do the rest with a generic
173 -- mechanism (deferred till later :)
174 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
175 mkConApp nm [] [] = ConApp nm
176 mkConApp nm [RepI] [a1] = ConAppI nm a1
177 mkConApp nm [RepP] [a1] = ConAppP nm a1
178 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
179 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
180 mkConApp nm reps args
181 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
183 mkLam RepP RepP = LamPP
184 mkLam RepI RepP = LamIP
185 mkLam RepP RepI = LamPI
186 mkLam RepI RepI = LamII
187 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
189 mkApp RepP RepP = AppPP
190 mkApp RepI RepP = AppIP
191 mkApp RepP RepI = AppPI
192 mkApp RepI RepI = AppII
193 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
196 repOfId = primRep2Rep . idPrimRep
201 -- genuine lifted types
204 -- all these are unboxed, fit into a word, and we assume they
205 -- all have the same call/return convention.
213 -- these are pretty dodgy: really pointers, but
214 -- we can't let the compiler build thunks with these reps.
215 ForeignObjRep -> RepP
216 StableNameRep -> RepP
224 other -> pprPanic "primRep2Rep" (ppr other)
226 repOfStgExpr :: StgExpr -> Rep
231 StgCase scrut live liveR bndr srt alts
232 -> case altRhss alts of
233 (a:_) -> repOfStgExpr a
234 [] -> panic "repOfStgExpr: no alts"
238 -> repOfApp ((deNoteType.repType.idType) var) (length args)
240 StgPrimApp op args res_ty
241 -> (primRep2Rep.typePrimRep) res_ty
243 StgLet binds body -> repOfStgExpr body
244 StgLetNoEscape live liveR binds body -> repOfStgExpr body
246 StgConApp con args -> RepP -- by definition
249 -> pprPanic "repOfStgExpr" (ppr other)
251 altRhss (StgAlgAlts tycon alts def)
252 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
253 altRhss (StgPrimAlts tycon alts def)
254 = [rhs | (lit,rhs) <- alts] ++ defRhs def
257 defRhs (StgBindDefault rhs)
260 -- returns the Rep of the result of applying ty to n args.
261 repOfApp :: Type -> Int -> Rep
262 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
263 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
275 MachStr _ -> RepI -- because it's a ptr outside the heap
276 other -> pprPanic "repOfLit" (ppr lit)
278 lit2expr :: Literal -> UnlinkedIExpr
281 MachInt i -> case fromIntegral i of I# i -> LitI i
282 MachWord i -> case fromIntegral i of I# i -> LitI i
283 MachAddr i -> case fromIntegral i of I# i -> LitI i
284 MachChar i -> case fromIntegral i of I# i -> LitI i
285 MachFloat f -> case fromRational f of F# f -> LitF f
286 MachDouble f -> case fromRational f of D# f -> LitD f
289 CharStr s i -> LitI (addr2Int# s)
292 -- sigh, a string in the heap is no good to us. We need a
293 -- static C pointer, since the type of a string literal is
294 -- Addr#. So, copy the string into C land and introduce a
295 -- memory leak at the same time.
297 -- CAREFUL! Chars are 32 bits in ghc 4.09+
298 case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
299 strncpy a ba (fromIntegral n)
300 writeCharOffAddr addr n '\0'
302 of A# a -> LitI (addr2Int# a)
304 _ -> error "StgInterp.lit2expr: unhandled string constant type"
306 other -> pprPanic "lit2expr" (ppr lit)
308 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
312 -> mkVar ie (repOfId var) var
315 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
319 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
320 | repOfStgExpr scrut /= RepP
321 -> mkCasePrim (repOfStgExpr stgexpr)
322 bndr (stg2expr ie scrut)
326 StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
327 | repOfStgExpr scrut == RepP
328 -> mkCaseAlg (repOfStgExpr stgexpr)
329 bndr (stg2expr ie scrut)
333 StgPrimApp op args res_ty
334 -> mkPrimOp (repOfStgExpr stgexpr)
335 op (map (arg2expr ie) args)
338 -> conapp2expr ie dcon args
340 StgLet binds@(StgNonRec v e) body
341 -> mkNonRec (repOfStgExpr stgexpr)
342 (head (translateBind ie binds))
343 (stg2expr (addOneToUniqSet ie v) body)
345 StgLet binds@(StgRec bs) body
346 -> mkRec (repOfStgExpr stgexpr)
347 (translateBind ie binds)
348 (stg2expr (addListToUniqSet ie (map fst bs)) body)
350 -- treat let-no-escape just like let.
351 StgLetNoEscape _ _ binds body
352 -> stg2expr ie (StgLet binds body)
355 -> pprPanic "stg2expr" (ppr stgexpr)
358 = AltPrim (lit2expr lit) (stg2expr ie rhs)
359 doAlgAlt (dcon,vars,uses,rhs)
360 = AltAlg (dataConTag dcon - 1)
361 (map id2VaaRep (toHeapOrder vars))
362 (stg2expr (addListToUniqSet ie vars) rhs)
365 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
366 (rearranged,offsets) = unzip rearranged_w_offsets
370 def2expr StgNoDefault = Nothing
371 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
373 mkAppChain ie result_rep so_far []
375 mkAppChain ie result_rep so_far [a]
376 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
377 mkAppChain ie result_rep so_far (a:as)
378 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
380 mkCasePrim RepI = CasePrimI
381 mkCasePrim RepP = CasePrimP
383 mkCaseAlg RepI = CaseAlgI
384 mkCaseAlg RepP = CaseAlgP
386 -- any var that isn't in scope is turned into a Native
388 | var `elementOfUniqSet` ie =
394 | otherwise = Native (toRdrName var)
398 mkNonRec RepI = NonRecI
399 mkNonRec RepP = NonRecP
401 mkPrimOp RepI = PrimOpI
402 mkPrimOp RepP = PrimOpP
404 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
405 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
406 arg2expr ie (StgLitArg lit) = lit2expr lit
407 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
409 repOfArg :: StgArg -> Rep
410 repOfArg (StgVarArg v) = repOfId v
411 repOfArg (StgLitArg lit) = repOfLit lit
412 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
414 id2VaaRep var = (var, repOfId var)
417 -- ---------------------------------------------------------------------------
418 -- Link interpretables into something we can run
419 -- ---------------------------------------------------------------------------
421 linkIModules :: ItblEnv -- incoming global itbl env; returned updated
422 -> ClosureEnv -- incoming global closure env; returned updated
423 -> [([UnlinkedIBind], ItblEnv)]
424 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
425 linkIModules gie gce mods = do
426 let (bindss, ies) = unzip mods
427 binds = concat bindss
428 top_level_binders = map (toRdrName.binder) binds
429 final_gie = foldr plusFM gie ies
432 new_gce = addListToFM gce (zip top_level_binders new_rhss)
433 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
434 --vvvvvvvvv----------------------------------------^^^^^^^^^-- circular
435 new_binds = linkIBinds final_gie new_gce binds
437 return (new_binds, final_gie, new_gce)
440 -- We're supposed to augment the environments with the values of any
441 -- external functions/info tables we need as we go along, but that's a
442 -- lot of hassle so for now I'll look up external things as they crop
443 -- up and not cache them in the source symbol tables. The interpreted
444 -- code will still be referenced in the source symbol tables.
446 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
447 linkIBinds ie ce binds = map (linkIBind ie ce) binds
449 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
451 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> LinkedIExpr
452 linkIExpr ie ce expr = case expr of
454 CaseAlgP bndr expr alts dflt ->
455 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
456 (linkDefault ie ce dflt)
458 CaseAlgI bndr expr alts dflt ->
459 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
460 (linkDefault ie ce dflt)
462 CasePrimP bndr expr alts dflt ->
463 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
464 (linkDefault ie ce dflt)
466 CasePrimI bndr expr alts dflt ->
467 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
468 (linkDefault ie ce dflt)
471 ConApp (lookupCon ie con)
474 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
477 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
479 ConAppPP con arg0 arg1 ->
480 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
482 ConAppPPP con arg0 arg1 arg2 ->
483 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
484 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
486 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
487 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
489 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
490 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
492 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
493 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
499 Native var -> lookupNative ce var
501 VarP v -> lookupVar ce VarP v
502 VarI v -> lookupVar ce VarI v
504 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
505 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
506 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
507 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
509 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
510 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
511 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
512 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
515 case lookupFM ie con of
516 Just (Ptr addr) -> addr
518 -- try looking up in the object files.
520 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
522 Nothing -> pprPanic "linkIExpr" (ppr con)
524 lookupNative ce var =
525 case lookupFM ce var of
528 -- try looking up in the object files.
529 let lbl = (rdrNameToCLabel var "closure")
530 addr = unsafePerformIO (lookupSymbol lbl) in
531 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
532 Just (A# addr) -> Native (unsafeCoerce# addr)
533 Nothing -> pprPanic "linkIExpr" (ppr var)
535 -- some VarI/VarP refer to top-level interpreted functions; we change
536 -- them into Natives here.
538 case lookupFM ce (toRdrName v) of
542 -- HACK!!! ToDo: cleaner
543 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
544 rdrNameToCLabel rn suffix =
545 _UNPK_(moduleNameFS (rdrNameModule rn))
546 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
548 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
549 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
551 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
552 linkPrimAlt ie ce (AltPrim lit rhs)
553 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
555 linkDefault ie ce Nothing = Nothing
556 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
558 -- ---------------------------------------------------------------------------
559 -- The interpreter proper
560 -- ---------------------------------------------------------------------------
562 -- The dynamic environment contains everything boxed.
563 -- eval* functions which look up values in it will know the
564 -- representation of the thing they are looking up, so they
565 -- can cast/unbox it as necessary.
567 -- ---------------------------------------------------------------------------
568 -- Evaluator for things of boxed (pointer) representation
569 -- ---------------------------------------------------------------------------
571 interp :: LinkedIExpr -> HValue
572 interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
574 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
578 -- | trace ("evalP: " ++ showExprTag expr) False
579 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
580 = error "evalP: ?!?!"
583 evalP (Native p) de = unsafeCoerce# p
585 -- First try the dynamic env. If that fails, assume it's a top-level
586 -- binding and look in the static env. That gives an Expr, which we
587 -- must convert to a boxed thingy by applying evalP to it. Because
588 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
589 -- CAFs), it's always safe to use evalP.
591 = case lookupUFM de v of
593 Nothing -> error ("evalP: lookupUFM " ++ show v)
595 -- Deal with application of a function returning a pointer rep
596 -- to arguments of any persuasion. Note that the function itself
597 -- always has pointer rep.
598 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
599 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
600 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
601 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
603 -- Lambdas always return P-rep, but we need to do different things
604 -- depending on both the argument and result representations.
606 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
608 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
610 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
612 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
614 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
616 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
618 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
620 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
622 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
624 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
626 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
628 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
630 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
632 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
634 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
636 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
639 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
640 -- except in the sense that we go on and evaluate the body with whichever
641 -- evaluator was used for the expression as a whole.
642 evalP (NonRecP bind e) de
643 = evalP e (augment_nonrec bind de)
644 evalP (RecP binds b) de
645 = evalP b (augment_rec binds de)
646 evalP (CaseAlgP bndr expr alts def) de
647 = case helper_caseAlg bndr expr alts def de of
648 (rhs, de') -> evalP rhs de'
649 evalP (CasePrimP bndr expr alts def) de
650 = case helper_casePrim bndr expr alts def de of
651 (rhs, de') -> evalP rhs de'
654 -- ConApp can only be handled by evalP
655 evalP (ConApp itbl args) se de
658 -- This appalling hack suggested (gleefully) by SDM
659 -- It is not well typed (needless to say?)
660 loop :: [Expr] -> boxed
662 = trace "loop-empty" (
663 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
666 = trace "loop-not-empty" (
668 RepI -> case evalI a de of i# -> loop as i#
669 RepP -> let p = evalP a de in loop as p
673 evalP (ConAppI (A# itbl) a1) de
674 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
676 evalP (ConApp (A# itbl)) de
677 = mci_make_constr itbl
679 evalP (ConAppP (A# itbl) a1) de
680 = let p1 = evalP a1 de
681 in mci_make_constrP itbl p1
683 evalP (ConAppPP (A# itbl) a1 a2) de
684 = let p1 = evalP a1 de
686 in mci_make_constrPP itbl p1 p2
688 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
689 = let p1 = evalP a1 de
692 in mci_make_constrPPP itbl p1 p2 p3
697 = error ("evalP: unhandled case: " ++ showExprTag other)
699 --------------------------------------------------------
700 --- Evaluator for things of Int# representation
701 --------------------------------------------------------
703 -- Evaluate something which has an unboxed Int rep
704 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
708 -- | trace ("evalI: " ++ showExprTag expr) False
709 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
710 = error "evalI: ?!?!"
713 evalI (LitI i#) de = i#
716 case lookupUFM de v of
717 Just e -> case unsafeCoerce# e of I# i -> i
718 Nothing -> error ("evalI: lookupUFM " ++ show v)
720 -- Deal with application of a function returning an Int# rep
721 -- to arguments of any persuasion. Note that the function itself
722 -- always has pointer rep.
723 evalI (AppII e1 e2) de
724 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
725 evalI (AppPI e1 e2) de
726 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
727 evalI (AppFI e1 e2) de
728 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
729 evalI (AppDI e1 e2) de
730 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
732 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
733 -- except in the sense that we go on and evaluate the body with whichever
734 -- evaluator was used for the expression as a whole.
735 evalI (NonRecI bind b) de
736 = evalI b (augment_nonrec bind de)
737 evalI (RecI binds b) de
738 = evalI b (augment_rec binds de)
739 evalI (CaseAlgI bndr expr alts def) de
740 = case helper_caseAlg bndr expr alts def de of
741 (rhs, de') -> evalI rhs de'
742 evalI (CasePrimI bndr expr alts def) de
743 = case helper_casePrim bndr expr alts def de of
744 (rhs, de') -> evalI rhs de'
746 -- evalI can't be applied to a lambda term, by defn, since those
749 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
750 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
752 --evalI (NonRec (IBind v e) b) de
753 -- = evalI b (augment de v (eval e de))
756 = error ("evalI: unhandled case: " ++ showExprTag other)
758 --------------------------------------------------------
759 --- Evaluator for things of Float# representation
760 --------------------------------------------------------
762 -- Evaluate something which has an unboxed Int rep
763 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
767 -- | trace ("evalF: " ++ showExprTag expr) False
768 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
769 = error "evalF: ?!?!"
772 evalF (LitF f#) de = f#
775 case lookupUFM de v of
776 Just e -> case unsafeCoerce# e of F# i -> i
777 Nothing -> error ("evalF: lookupUFM " ++ show v)
779 -- Deal with application of a function returning an Int# rep
780 -- to arguments of any persuasion. Note that the function itself
781 -- always has pointer rep.
782 evalF (AppIF e1 e2) de
783 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
784 evalF (AppPF e1 e2) de
785 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
786 evalF (AppFF e1 e2) de
787 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
788 evalF (AppDF e1 e2) de
789 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
791 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
792 -- except in the sense that we go on and evaluate the body with whichever
793 -- evaluator was used for the expression as a whole.
794 evalF (NonRecF bind b) de
795 = evalF b (augment_nonrec bind de)
796 evalF (RecF binds b) de
797 = evalF b (augment_rec binds de)
798 evalF (CaseAlgF bndr expr alts def) de
799 = case helper_caseAlg bndr expr alts def de of
800 (rhs, de') -> evalF rhs de'
801 evalF (CasePrimF bndr expr alts def) de
802 = case helper_casePrim bndr expr alts def de of
803 (rhs, de') -> evalF rhs de'
805 -- evalF can't be applied to a lambda term, by defn, since those
808 evalF (PrimOpF op _) de
809 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
812 = error ("evalF: unhandled case: " ++ showExprTag other)
814 --------------------------------------------------------
815 --- Evaluator for things of Double# representation
816 --------------------------------------------------------
818 -- Evaluate something which has an unboxed Int rep
819 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
823 -- | trace ("evalD: " ++ showExprTag expr) False
824 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
825 = 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 (RecP _ _) = RepP
917 repOf (RecI _ _) = RepI
918 repOf (RecF _ _) = RepF
919 repOf (RecD _ _) = RepD
921 repOf (LitI _) = RepI
922 repOf (LitF _) = RepF
923 repOf (LitD _) = RepD
925 repOf (Native _) = RepP
927 repOf (VarP _) = RepI
928 repOf (VarI _) = RepI
929 repOf (VarF _) = RepF
930 repOf (VarD _) = RepD
932 repOf (PrimOpP _ _) = RepP
933 repOf (PrimOpI _ _) = RepI
934 repOf (PrimOpF _ _) = RepF
935 repOf (PrimOpD _ _) = RepD
937 repOf (ConApp _) = RepP
938 repOf (ConAppI _ _) = RepP
939 repOf (ConAppP _ _) = RepP
940 repOf (ConAppPP _ _ _) = RepP
941 repOf (ConAppPPP _ _ _ _) = RepP
943 repOf (CaseAlgP _ _ _ _) = RepP
944 repOf (CaseAlgI _ _ _ _) = RepI
945 repOf (CaseAlgF _ _ _ _) = RepF
946 repOf (CaseAlgD _ _ _ _) = RepD
948 repOf (CasePrimP _ _ _ _) = RepP
949 repOf (CasePrimI _ _ _ _) = RepI
950 repOf (CasePrimF _ _ _ _) = RepF
951 repOf (CasePrimD _ _ _ _) = RepD
954 = error ("repOf: unhandled case: " ++ showExprTag other)
956 -- how big (in words) is one of these
957 repSizeW :: Rep -> Int
962 -- Evaluate an expression, using the appropriate evaluator,
963 -- then box up the result. Note that it's only safe to use this
964 -- to create values to put in the environment. You can't use it
965 -- to create a value which might get passed to native code since that
966 -- code will have no idea that unboxed things have been boxed.
967 eval :: LinkedIExpr -> UniqFM boxed -> boxed
970 RepI -> unsafeCoerce# (I# (evalI expr de))
971 RepP -> evalP expr de
972 RepF -> unsafeCoerce# (F# (evalF expr de))
973 RepD -> unsafeCoerce# (D# (evalD expr de))
975 -- Evaluate the scrutinee of a case, select an alternative,
976 -- augment the environment appropriately, and return the alt
977 -- and the augmented environment.
978 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
980 -> (LinkedIExpr, UniqFM boxed)
981 helper_caseAlg bndr expr alts def de
982 = let exprEv = evalP expr de
984 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
985 case select_altAlg (tagOf exprEv) alts def of
986 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
989 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
991 -> (LinkedIExpr, UniqFM boxed)
992 helper_casePrim bndr expr alts def de
994 -- Umm, can expr have any other rep? Yes ...
995 -- CharRep, DoubleRep, FloatRep. What about string reps?
996 RepI -> case evalI expr de of
997 i# -> (select_altPrim alts def (LitI i#),
998 addToUFM de bndr (unsafeCoerce# (I# i#)))
1001 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1002 augment_from_constr de con ([],offset)
1004 augment_from_constr de con ((v,rep):vs,offset)
1007 RepP -> indexPtrOffClosure con offset
1008 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1010 augment_from_constr (addToUFM de v v_binding) con
1011 (vs,offset + repSizeW rep)
1013 -- Augment the environment for a non-recursive let.
1014 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1015 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1017 -- Augment the environment for a recursive let.
1018 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1019 augment_rec binds de
1020 = let vars = map binder binds
1021 rhss = map bindee binds
1022 rhs_vs = map (\rhs -> eval rhs de') rhss
1023 de' = addListToUFM de (zip vars rhs_vs)
1027 -- a must be a constructor?
1029 tagOf x = I# (dataToTag# x)
1031 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1032 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1033 select_altAlg tag [] (Just def) = ([],def)
1034 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1037 else select_altAlg tag alts def
1039 -- literal may only be a literal, not an arbitrary expression
1040 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1041 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1042 select_altPrim [] (Just def) literal = def
1043 select_altPrim ((AltPrim lit rhs):alts) def literal
1044 = if eqLits lit literal
1046 else select_altPrim alts def literal
1048 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1051 -- a is a constructor
1052 indexPtrOffClosure :: a -> Int -> b
1053 indexPtrOffClosure con (I# offset)
1054 = case indexPtrOffClosure# con offset of (# x #) -> x
1056 indexIntOffClosure :: a -> Int -> Int#
1057 indexIntOffClosure con (I# offset)
1058 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1061 ------------------------------------------------------------------------
1062 --- Manufacturing of info tables for DataCons defined in this module ---
1063 ------------------------------------------------------------------------
1065 #if __GLASGOW_HASKELL__ <= 408
1068 type ItblPtr = Ptr StgInfoTable
1071 -- Make info tables for the data decls in this module
1072 mkITbls :: [TyCon] -> IO ItblEnv
1073 mkITbls [] = return emptyFM
1074 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1075 itbls2 <- mkITbls tcs
1076 return (itbls `plusFM` itbls2)
1078 mkITbl :: TyCon -> IO ItblEnv
1080 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1082 | not (isDataTyCon tc)
1084 | n == length dcs -- paranoia; this is an assertion.
1085 = make_constr_itbls dcs
1087 dcs = tyConDataCons tc
1088 n = tyConFamilySize tc
1091 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1093 -- Assumes constructors are numbered from zero, not one
1094 make_constr_itbls :: [DataCon] -> IO ItblEnv
1095 make_constr_itbls cons
1097 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1098 return (listToFM is)
1100 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1101 return (listToFM is)
1103 mk_vecret_itbl (dcon, conNo)
1104 = mk_itbl dcon conNo (vecret_entry conNo)
1105 mk_dirret_itbl (dcon, conNo)
1106 = mk_itbl dcon conNo mci_constr_entry
1108 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
1109 mk_itbl dcon conNo entry_addr
1110 = let (tot_wds, ptr_wds, _)
1111 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1113 nptrs = tot_wds - ptr_wds
1114 itbl = StgInfoTable {
1115 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1116 tipe = fromIntegral cONSTR,
1117 srtlen = fromIntegral conNo,
1118 code0 = fromIntegral code0, code1 = fromIntegral code1,
1119 code2 = fromIntegral code2, code3 = fromIntegral code3,
1120 code4 = fromIntegral code4, code5 = fromIntegral code5,
1121 code6 = fromIntegral code6, code7 = fromIntegral code7
1123 -- Make a piece of code to jump to "entry_label".
1124 -- This is the only arch-dependent bit.
1125 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1126 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1128 -- B8 ZZ YY XX WW FF E0
1129 (code0,code1,code2,code3,code4,code5,code6,code7)
1130 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1131 byte 2 entry_addr_w, byte 3 entry_addr_w,
1135 entry_addr_w :: Word32
1136 entry_addr_w = fromIntegral (addrToInt entry_addr)
1139 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1140 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1141 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1143 return (toRdrName dcon, addr `plusPtr` 8)
1146 byte :: Int -> Word32 -> Word32
1147 byte 0 w = w .&. 0xFF
1148 byte 1 w = (w `shiftR` 8) .&. 0xFF
1149 byte 2 w = (w `shiftR` 16) .&. 0xFF
1150 byte 3 w = (w `shiftR` 24) .&. 0xFF
1153 vecret_entry 0 = mci_constr1_entry
1154 vecret_entry 1 = mci_constr2_entry
1155 vecret_entry 2 = mci_constr3_entry
1156 vecret_entry 3 = mci_constr4_entry
1157 vecret_entry 4 = mci_constr5_entry
1158 vecret_entry 5 = mci_constr6_entry
1159 vecret_entry 6 = mci_constr7_entry
1160 vecret_entry 7 = mci_constr8_entry
1162 -- entry point for direct returns for created constr itbls
1163 foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1164 -- and the 8 vectored ones
1165 foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
1166 foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
1167 foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
1168 foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
1169 foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
1170 foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
1171 foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
1172 foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1176 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1179 -- Ultra-minimalist version specially for constructors
1180 data StgInfoTable = StgInfoTable {
1185 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1189 instance Storable StgInfoTable where
1192 = (sum . map (\f -> f itbl))
1193 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1194 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1195 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1198 = (sum . map (\f -> f itbl))
1199 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1200 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1201 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1204 = do a1 <- store (ptrs itbl) (castPtr a0)
1205 a2 <- store (nptrs itbl) a1
1206 a3 <- store (tipe itbl) a2
1207 a4 <- store (srtlen itbl) a3
1208 a5 <- store (code0 itbl) a4
1209 a6 <- store (code1 itbl) a5
1210 a7 <- store (code2 itbl) a6
1211 a8 <- store (code3 itbl) a7
1212 a9 <- store (code4 itbl) a8
1213 aA <- store (code5 itbl) a9
1214 aB <- store (code6 itbl) aA
1215 aC <- store (code7 itbl) aB
1219 = do (a1,ptrs) <- load (castPtr a0)
1220 (a2,nptrs) <- load a1
1221 (a3,tipe) <- load a2
1222 (a4,srtlen) <- load a3
1223 (a5,code0) <- load a4
1224 (a6,code1) <- load a5
1225 (a7,code2) <- load a6
1226 (a8,code3) <- load a7
1227 (a9,code4) <- load a8
1228 (aA,code5) <- load a9
1229 (aB,code6) <- load aA
1230 (aC,code7) <- load aB
1231 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1232 srtlen = srtlen, tipe = tipe,
1233 code0 = code0, code1 = code1, code2 = code2,
1234 code3 = code3, code4 = code4, code5 = code5,
1235 code6 = code6, code7 = code7 }
1237 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1238 fieldSz sel x = sizeOf (sel x)
1240 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1241 fieldAl sel x = alignment (sel x)
1243 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1244 store x addr = do poke addr x
1245 return (castPtr (addr `plusPtr` sizeOf x))
1247 load :: Storable a => Ptr a -> IO (Ptr b, a)
1248 load addr = do x <- peek addr
1249 return (castPtr (addr `plusPtr` sizeOf x), x)
1251 -----------------------------------------------------------------------------q
1253 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()