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, isUnqual )
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 reps args = ConAppGen nm args
186 mkLam RepP RepP = LamPP
187 mkLam RepI RepP = LamIP
188 mkLam RepP RepI = LamPI
189 mkLam RepI RepI = LamII
190 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
192 mkApp RepP RepP = AppPP
193 mkApp RepI RepP = AppIP
194 mkApp RepP RepI = AppPI
195 mkApp RepI RepI = AppII
196 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
199 repOfId = primRep2Rep . idPrimRep
204 -- genuine lifted types
207 -- all these are unboxed, fit into a word, and we assume they
208 -- all have the same call/return convention.
216 -- these are pretty dodgy: really pointers, but
217 -- we can't let the compiler build thunks with these reps.
218 ForeignObjRep -> RepP
219 StableNameRep -> RepP
227 other -> pprPanic "primRep2Rep" (ppr other)
229 repOfStgExpr :: StgExpr -> Rep
234 StgCase scrut live liveR bndr srt alts
235 -> case altRhss alts of
236 (a:_) -> repOfStgExpr a
237 [] -> panic "repOfStgExpr: no alts"
241 -> repOfApp ((deNoteType.repType.idType) var) (length args)
243 StgPrimApp op args res_ty
244 -> (primRep2Rep.typePrimRep) res_ty
246 StgLet binds body -> repOfStgExpr body
247 StgLetNoEscape live liveR binds body -> repOfStgExpr body
249 StgConApp con args -> RepP -- by definition
252 -> pprPanic "repOfStgExpr" (ppr other)
254 altRhss (StgAlgAlts tycon alts def)
255 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
256 altRhss (StgPrimAlts tycon alts def)
257 = [rhs | (lit,rhs) <- alts] ++ defRhs def
260 defRhs (StgBindDefault rhs)
263 -- returns the Rep of the result of applying ty to n args.
264 repOfApp :: Type -> Int -> Rep
265 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
266 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
278 MachStr _ -> RepI -- because it's a ptr outside the heap
279 other -> pprPanic "repOfLit" (ppr lit)
281 lit2expr :: Literal -> UnlinkedIExpr
284 MachInt i -> case fromIntegral i of I# i -> LitI i
285 MachWord i -> case fromIntegral i of I# i -> LitI i
286 MachAddr i -> case fromIntegral i of I# i -> LitI i
287 MachChar i -> case fromIntegral i of I# i -> LitI i
288 MachFloat f -> case fromRational f of F# f -> LitF f
289 MachDouble f -> case fromRational f of D# f -> LitD f
292 CharStr s i -> LitI (addr2Int# s)
295 -- sigh, a string in the heap is no good to us. We need a
296 -- static C pointer, since the type of a string literal is
297 -- Addr#. So, copy the string into C land and introduce a
298 -- memory leak at the same time.
300 -- CAREFUL! Chars are 32 bits in ghc 4.09+
301 case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
302 strncpy a ba (fromIntegral n)
303 writeCharOffAddr addr n '\0'
305 of A# a -> LitI (addr2Int# a)
307 _ -> error "StgInterp.lit2expr: unhandled string constant type"
309 other -> pprPanic "lit2expr" (ppr lit)
311 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
315 -> mkVar ie (repOfId var) var
318 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
322 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
323 | repOfStgExpr scrut /= RepP
324 -> mkCasePrim (repOfStgExpr stgexpr)
325 bndr (stg2expr ie scrut)
326 (map (doPrimAlt ie') alts)
328 where ie' = addOneToUniqSet ie bndr
330 StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
331 | repOfStgExpr scrut == RepP
332 -> mkCaseAlg (repOfStgExpr stgexpr)
333 bndr (stg2expr ie scrut)
334 (map (doAlgAlt ie') alts)
336 where ie' = addOneToUniqSet ie bndr
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)
362 doPrimAlt ie (lit,rhs)
363 = AltPrim (lit2expr lit) (stg2expr ie rhs)
364 doAlgAlt ie (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 ie StgNoDefault = Nothing
376 def2expr ie (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 CaseAlgF bndr expr alts dflt ->
468 CaseAlgF bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
469 (linkDefault ie ce dflt)
471 CaseAlgD bndr expr alts dflt ->
472 CaseAlgD bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
473 (linkDefault ie ce dflt)
475 CasePrimP bndr expr alts dflt ->
476 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
477 (linkDefault ie ce dflt)
479 CasePrimI bndr expr alts dflt ->
480 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
481 (linkDefault ie ce dflt)
483 CasePrimF bndr expr alts dflt ->
484 CasePrimF bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
485 (linkDefault ie ce dflt)
487 CasePrimD bndr expr alts dflt ->
488 CasePrimD bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
489 (linkDefault ie ce dflt)
492 lookupNullaryCon ie con
495 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
498 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
500 ConAppPP con arg0 arg1 ->
501 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
502 ConAppGen con args -> ConAppGen (lookupCon ie con)
503 (map (linkIExpr ie ce) args)
505 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
506 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
508 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
509 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
510 NonRecF bind expr -> NonRecF (linkIBind ie ce bind) (linkIExpr ie ce expr)
511 NonRecD bind expr -> NonRecD (linkIBind ie ce bind) (linkIExpr ie ce expr)
513 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
514 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
515 RecF binds expr -> RecF (linkIBinds ie ce binds) (linkIExpr ie ce expr)
516 RecD binds expr -> RecD (linkIBinds ie ce binds) (linkIExpr ie ce expr)
522 Native var -> lookupNative ce var
524 VarP v -> lookupVar ce VarP v
525 VarI v -> lookupVar ce VarI v
526 VarF v -> lookupVar ce VarF v
527 VarD v -> lookupVar ce VarD v
529 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
530 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
531 LamPF bndr expr -> LamPF bndr (linkIExpr ie ce expr)
532 LamPD bndr expr -> LamPD bndr (linkIExpr ie ce expr)
533 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
534 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
535 LamIF bndr expr -> LamIF bndr (linkIExpr ie ce expr)
536 LamID bndr expr -> LamID bndr (linkIExpr ie ce expr)
537 LamFP bndr expr -> LamFP bndr (linkIExpr ie ce expr)
538 LamFI bndr expr -> LamFI bndr (linkIExpr ie ce expr)
539 LamFF bndr expr -> LamFF bndr (linkIExpr ie ce expr)
540 LamFD bndr expr -> LamFD bndr (linkIExpr ie ce expr)
541 LamDP bndr expr -> LamDP bndr (linkIExpr ie ce expr)
542 LamDI bndr expr -> LamDI bndr (linkIExpr ie ce expr)
543 LamDF bndr expr -> LamDF bndr (linkIExpr ie ce expr)
544 LamDD bndr expr -> LamDD bndr (linkIExpr ie ce expr)
546 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
547 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
548 AppPF fun arg -> AppPF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
549 AppPD fun arg -> AppPD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
550 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
551 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
552 AppIF fun arg -> AppIF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
553 AppID fun arg -> AppID (linkIExpr ie ce fun) (linkIExpr ie ce arg)
554 AppFP fun arg -> AppFP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
555 AppFI fun arg -> AppFI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
556 AppFF fun arg -> AppFF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
557 AppFD fun arg -> AppFD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
558 AppDP fun arg -> AppDP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
559 AppDI fun arg -> AppDI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
560 AppDF fun arg -> AppDF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
561 AppDD fun arg -> AppDD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
564 case lookupFM ie con of
565 Just (Ptr addr) -> addr
567 -- try looking up in the object files.
569 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
571 Nothing -> pprPanic "linkIExpr" (ppr con)
573 -- nullary constructors don't have normal _con_info tables.
574 lookupNullaryCon ie con =
575 case lookupFM ie con of
576 Just (Ptr addr) -> ConApp addr
578 -- try looking up in the object files.
580 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "closure")) of
581 Just (A# addr) -> Native (unsafeCoerce# addr)
582 Nothing -> pprPanic "lookupNullaryCon" (ppr con)
585 lookupNative ce var =
586 case lookupFM ce var of
589 -- try looking up in the object files.
590 let lbl = (rdrNameToCLabel var "closure")
591 addr = unsafePerformIO (lookupSymbol lbl) in
592 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
593 Just (A# addr) -> Native (unsafeCoerce# addr)
594 Nothing -> pprPanic "linkIExpr" (ppr var)
596 -- some VarI/VarP refer to top-level interpreted functions; we change
597 -- them into Natives here.
599 case lookupFM ce (toRdrName v) of
603 -- HACK!!! ToDo: cleaner
604 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
605 rdrNameToCLabel rn suffix
606 | isUnqual rn = pprPanic "rdrNameToCLabel" (ppr rn)
608 _UNPK_(moduleNameFS (rdrNameModule rn))
609 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
611 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
612 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
614 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
615 linkPrimAlt ie ce (AltPrim lit rhs)
616 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
618 linkDefault ie ce Nothing = Nothing
619 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
621 -- ---------------------------------------------------------------------------
622 -- The interpreter proper
623 -- ---------------------------------------------------------------------------
625 -- The dynamic environment contains everything boxed.
626 -- eval* functions which look up values in it will know the
627 -- representation of the thing they are looking up, so they
628 -- can cast/unbox it as necessary.
630 -- ---------------------------------------------------------------------------
631 -- Evaluator for things of boxed (pointer) representation
632 -- ---------------------------------------------------------------------------
634 interp :: LinkedIExpr -> HValue
635 interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
637 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
641 -- | trace ("evalP: " ++ showExprTag expr) False
642 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
643 = error "evalP: ?!?!"
646 evalP (Native p) de = unsafeCoerce# p
648 -- First try the dynamic env. If that fails, assume it's a top-level
649 -- binding and look in the static env. That gives an Expr, which we
650 -- must convert to a boxed thingy by applying evalP to it. Because
651 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
652 -- CAFs), it's always safe to use evalP.
654 = case lookupUFM de v of
656 Nothing -> error ("evalP: lookupUFM " ++ show v)
658 -- Deal with application of a function returning a pointer rep
659 -- to arguments of any persuasion. Note that the function itself
660 -- always has pointer rep.
661 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
662 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
663 evalP (AppFP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de)
664 evalP (AppDP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de)
666 -- Lambdas always return P-rep, but we need to do different things
667 -- depending on both the argument and result representations.
669 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
671 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
673 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
675 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
677 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
679 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
681 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
683 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
685 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
687 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
689 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
691 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
693 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
695 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
697 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
699 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
702 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
703 -- except in the sense that we go on and evaluate the body with whichever
704 -- evaluator was used for the expression as a whole.
705 evalP (NonRecP bind e) de
706 = evalP e (augment_nonrec bind de)
707 evalP (RecP binds b) de
708 = evalP b (augment_rec binds de)
709 evalP (CaseAlgP bndr expr alts def) de
710 = case helper_caseAlg bndr expr alts def de of
711 (rhs, de') -> evalP rhs de'
712 evalP (CasePrimP bndr expr alts def) de
713 = case helper_casePrim bndr expr alts def de of
714 (rhs, de') -> evalP rhs de'
716 evalP (ConApp (A# itbl)) de
717 = mci_make_constr0 itbl
719 evalP (ConAppI (A# itbl) a1) de
720 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
722 evalP (ConAppP (A# itbl) a1) de
723 = evalP (ConAppGen (A# itbl) [a1]) de
724 -- = let p1 = evalP a1 de
725 -- in mci_make_constrP itbl p1
727 evalP (ConAppPP (A# itbl) a1 a2) de
728 = let p1 = evalP a1 de
730 in mci_make_constrPP itbl p1 p2
732 evalP (ConAppGen itbl args) de
735 -- This appalling hack suggested (gleefully) by SDM
736 -- It is not well typed (needless to say?)
737 loop :: [LinkedIExpr] -> boxed
739 = case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
742 RepP -> let p = evalP a de in loop as p
743 RepI -> case evalI a de of i# -> loop as i#
744 RepF -> case evalF a de of f# -> loop as f#
745 RepD -> case evalD a de of d# -> loop as d#
748 = error ("evalP: unhandled case: " ++ showExprTag other)
750 --------------------------------------------------------
751 --- Evaluator for things of Int# representation
752 --------------------------------------------------------
754 -- Evaluate something which has an unboxed Int rep
755 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
759 -- | trace ("evalI: " ++ showExprTag expr) False
760 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
761 = error "evalI: ?!?!"
764 evalI (LitI i#) de = i#
767 case lookupUFM de v of
768 Just e -> case unsafeCoerce# e of I# i -> i
769 Nothing -> error ("evalI: lookupUFM " ++ show v)
771 -- Deal with application of a function returning an Int# rep
772 -- to arguments of any persuasion. Note that the function itself
773 -- always has pointer rep.
774 evalI (AppII e1 e2) de
775 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
776 evalI (AppPI e1 e2) de
777 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
778 evalI (AppFI e1 e2) de
779 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
780 evalI (AppDI e1 e2) de
781 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
783 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
784 -- except in the sense that we go on and evaluate the body with whichever
785 -- evaluator was used for the expression as a whole.
786 evalI (NonRecI bind b) de
787 = evalI b (augment_nonrec bind de)
788 evalI (RecI binds b) de
789 = evalI b (augment_rec binds de)
790 evalI (CaseAlgI bndr expr alts def) de
791 = case helper_caseAlg bndr expr alts def de of
792 (rhs, de') -> evalI rhs de'
793 evalI (CasePrimI bndr expr alts def) de
794 = case helper_casePrim bndr expr alts def de of
795 (rhs, de') -> evalI rhs de'
797 -- evalI can't be applied to a lambda term, by defn, since those
800 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
801 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
803 --evalI (NonRec (IBind v e) b) de
804 -- = evalI b (augment de v (eval e de))
807 = error ("evalI: unhandled case: " ++ showExprTag other)
809 --------------------------------------------------------
810 --- Evaluator for things of Float# representation
811 --------------------------------------------------------
813 -- Evaluate something which has an unboxed Int rep
814 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
818 -- | trace ("evalF: " ++ showExprTag expr) False
819 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
820 = error "evalF: ?!?!"
823 evalF (LitF f#) de = f#
826 case lookupUFM de v of
827 Just e -> case unsafeCoerce# e of F# i -> i
828 Nothing -> error ("evalF: lookupUFM " ++ show v)
830 -- Deal with application of a function returning an Int# rep
831 -- to arguments of any persuasion. Note that the function itself
832 -- always has pointer rep.
833 evalF (AppIF e1 e2) de
834 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
835 evalF (AppPF e1 e2) de
836 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
837 evalF (AppFF e1 e2) de
838 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
839 evalF (AppDF e1 e2) de
840 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
842 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
843 -- except in the sense that we go on and evaluate the body with whichever
844 -- evaluator was used for the expression as a whole.
845 evalF (NonRecF bind b) de
846 = evalF b (augment_nonrec bind de)
847 evalF (RecF binds b) de
848 = evalF b (augment_rec binds de)
849 evalF (CaseAlgF bndr expr alts def) de
850 = case helper_caseAlg bndr expr alts def de of
851 (rhs, de') -> evalF rhs de'
852 evalF (CasePrimF bndr expr alts def) de
853 = case helper_casePrim bndr expr alts def de of
854 (rhs, de') -> evalF rhs de'
856 -- evalF can't be applied to a lambda term, by defn, since those
859 evalF (PrimOpF op _) de
860 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
863 = error ("evalF: unhandled case: " ++ showExprTag other)
865 --------------------------------------------------------
866 --- Evaluator for things of Double# representation
867 --------------------------------------------------------
869 -- Evaluate something which has an unboxed Int rep
870 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
874 -- | trace ("evalD: " ++ showExprTag expr) False
875 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
876 = error "evalD: ?!?!"
879 evalD (LitD d#) de = d#
882 case lookupUFM de v of
883 Just e -> case unsafeCoerce# e of D# i -> i
884 Nothing -> error ("evalD: lookupUFM " ++ show v)
886 -- Deal with application of a function returning an Int# rep
887 -- to arguments of any persuasion. Note that the function itself
888 -- always has pointer rep.
889 evalD (AppID e1 e2) de
890 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
891 evalD (AppPD e1 e2) de
892 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
893 evalD (AppFD e1 e2) de
894 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
895 evalD (AppDD e1 e2) de
896 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
898 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
899 -- except in the sense that we go on and evaluate the body with whichever
900 -- evaluator was used for the expression as a whole.
901 evalD (NonRecD bind b) de
902 = evalD b (augment_nonrec bind de)
903 evalD (RecD binds b) de
904 = evalD b (augment_rec binds de)
905 evalD (CaseAlgD bndr expr alts def) de
906 = case helper_caseAlg bndr expr alts def de of
907 (rhs, de') -> evalD rhs de'
908 evalD (CasePrimD bndr expr alts def) de
909 = case helper_casePrim bndr expr alts def de of
910 (rhs, de') -> evalD rhs de'
912 -- evalD can't be applied to a lambda term, by defn, since those
915 evalD (PrimOpD op _) de
916 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
919 = error ("evalD: unhandled case: " ++ showExprTag other)
921 --------------------------------------------------------
922 --- Helper bits and pieces
923 --------------------------------------------------------
925 -- Find the Rep of any Expr
926 repOf :: LinkedIExpr -> Rep
928 repOf (LamPP _ _) = RepP
929 repOf (LamPI _ _) = RepP
930 repOf (LamPF _ _) = RepP
931 repOf (LamPD _ _) = RepP
932 repOf (LamIP _ _) = RepP
933 repOf (LamII _ _) = RepP
934 repOf (LamIF _ _) = RepP
935 repOf (LamID _ _) = RepP
936 repOf (LamFP _ _) = RepP
937 repOf (LamFI _ _) = RepP
938 repOf (LamFF _ _) = RepP
939 repOf (LamFD _ _) = RepP
940 repOf (LamDP _ _) = RepP
941 repOf (LamDI _ _) = RepP
942 repOf (LamDF _ _) = RepP
943 repOf (LamDD _ _) = RepP
945 repOf (AppPP _ _) = RepP
946 repOf (AppPI _ _) = RepI
947 repOf (AppPF _ _) = RepF
948 repOf (AppPD _ _) = RepD
949 repOf (AppIP _ _) = RepP
950 repOf (AppII _ _) = RepI
951 repOf (AppIF _ _) = RepF
952 repOf (AppID _ _) = RepD
953 repOf (AppFP _ _) = RepP
954 repOf (AppFI _ _) = RepI
955 repOf (AppFF _ _) = RepF
956 repOf (AppFD _ _) = RepD
957 repOf (AppDP _ _) = RepP
958 repOf (AppDI _ _) = RepI
959 repOf (AppDF _ _) = RepF
960 repOf (AppDD _ _) = RepD
962 repOf (NonRecP _ _) = RepP
963 repOf (NonRecI _ _) = RepI
964 repOf (NonRecF _ _) = RepF
965 repOf (NonRecD _ _) = RepD
967 repOf (RecP _ _) = RepP
968 repOf (RecI _ _) = RepI
969 repOf (RecF _ _) = RepF
970 repOf (RecD _ _) = RepD
972 repOf (LitI _) = RepI
973 repOf (LitF _) = RepF
974 repOf (LitD _) = RepD
976 repOf (Native _) = RepP
978 repOf (VarP _) = RepP
979 repOf (VarI _) = RepI
980 repOf (VarF _) = RepF
981 repOf (VarD _) = RepD
983 repOf (PrimOpP _ _) = RepP
984 repOf (PrimOpI _ _) = RepI
985 repOf (PrimOpF _ _) = RepF
986 repOf (PrimOpD _ _) = RepD
988 repOf (ConApp _) = RepP
989 repOf (ConAppI _ _) = RepP
990 repOf (ConAppP _ _) = RepP
991 repOf (ConAppPP _ _ _) = RepP
992 repOf (ConAppGen _ _) = RepP
994 repOf (CaseAlgP _ _ _ _) = RepP
995 repOf (CaseAlgI _ _ _ _) = RepI
996 repOf (CaseAlgF _ _ _ _) = RepF
997 repOf (CaseAlgD _ _ _ _) = RepD
999 repOf (CasePrimP _ _ _ _) = RepP
1000 repOf (CasePrimI _ _ _ _) = RepI
1001 repOf (CasePrimF _ _ _ _) = RepF
1002 repOf (CasePrimD _ _ _ _) = RepD
1005 = error ("repOf: unhandled case: " ++ showExprTag other)
1007 -- how big (in words) is one of these
1008 repSizeW :: Rep -> Int
1013 -- Evaluate an expression, using the appropriate evaluator,
1014 -- then box up the result. Note that it's only safe to use this
1015 -- to create values to put in the environment. You can't use it
1016 -- to create a value which might get passed to native code since that
1017 -- code will have no idea that unboxed things have been boxed.
1018 eval :: LinkedIExpr -> UniqFM boxed -> boxed
1020 = case repOf expr of
1021 RepI -> unsafeCoerce# (I# (evalI expr de))
1022 RepP -> evalP expr de
1023 RepF -> unsafeCoerce# (F# (evalF expr de))
1024 RepD -> unsafeCoerce# (D# (evalD expr de))
1026 -- Evaluate the scrutinee of a case, select an alternative,
1027 -- augment the environment appropriately, and return the alt
1028 -- and the augmented environment.
1029 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
1031 -> (LinkedIExpr, UniqFM boxed)
1032 helper_caseAlg bndr expr alts def de
1033 = let exprEv = evalP expr de
1035 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
1036 case select_altAlg (tagOf exprEv) alts def of
1037 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
1040 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
1042 -> (LinkedIExpr, UniqFM boxed)
1043 helper_casePrim bndr expr alts def de
1044 = case repOf expr of
1045 RepI -> case evalI expr de of
1046 i# -> (select_altPrim alts def (LitI i#),
1047 addToUFM de bndr (unsafeCoerce# (I# i#)))
1048 RepF -> case evalF expr de of
1049 f# -> (select_altPrim alts def (LitF f#),
1050 addToUFM de bndr (unsafeCoerce# (F# f#)))
1051 RepD -> case evalD expr de of
1052 d# -> (select_altPrim alts def (LitD d#),
1053 addToUFM de bndr (unsafeCoerce# (D# d#)))
1056 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1057 augment_from_constr de con ([],offset)
1059 augment_from_constr de con ((v,rep):vs,offset)
1062 RepP -> indexPtrOffClosure con offset
1063 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1064 RepF -> unsafeCoerce# (F# (indexFloatOffClosure con offset))
1065 RepD -> unsafeCoerce# (D# (indexDoubleOffClosure con offset))
1067 augment_from_constr (addToUFM de v v_binding) con
1068 (vs,offset + repSizeW rep)
1070 -- Augment the environment for a non-recursive let.
1071 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1072 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1074 -- Augment the environment for a recursive let.
1075 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1076 augment_rec binds de
1077 = let vars = map binder binds
1078 rhss = map bindee binds
1079 rhs_vs = map (\rhs -> eval rhs de') rhss
1080 de' = addListToUFM de (zip vars rhs_vs)
1084 -- a must be a constructor?
1086 tagOf x = I# (dataToTag# x)
1088 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1089 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1090 select_altAlg tag [] (Just def) = ([],def)
1091 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1094 else select_altAlg tag alts def
1096 -- literal may only be a literal, not an arbitrary expression
1097 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1098 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1099 select_altPrim [] (Just def) literal = def
1100 select_altPrim ((AltPrim lit rhs):alts) def literal
1101 = if eqLits lit literal
1103 else select_altPrim alts def literal
1105 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1108 -- a is a constructor
1109 indexPtrOffClosure :: a -> Int -> b
1110 indexPtrOffClosure con (I# offset)
1111 = case indexPtrOffClosure# con offset of (# x #) -> x
1113 indexIntOffClosure :: a -> Int -> Int#
1114 indexIntOffClosure con (I# offset)
1115 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1117 indexFloatOffClosure :: a -> Int -> Float#
1118 indexFloatOffClosure con (I# offset)
1119 = unsafeCoerce# (indexWordOffClosure# con offset) -- eek!
1121 ------------------------------------------------------------------------
1122 --- Manufacturing of info tables for DataCons defined in this module ---
1123 ------------------------------------------------------------------------
1125 #if __GLASGOW_HASKELL__ <= 408
1128 type ItblPtr = Ptr StgInfoTable
1131 -- Make info tables for the data decls in this module
1132 mkITbls :: [TyCon] -> IO ItblEnv
1133 mkITbls [] = return emptyFM
1134 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1135 itbls2 <- mkITbls tcs
1136 return (itbls `plusFM` itbls2)
1138 mkITbl :: TyCon -> IO ItblEnv
1140 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1142 | not (isDataTyCon tc)
1144 | n == length dcs -- paranoia; this is an assertion.
1145 = make_constr_itbls dcs
1147 dcs = tyConDataCons tc
1148 n = tyConFamilySize tc
1151 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1153 -- Assumes constructors are numbered from zero, not one
1154 make_constr_itbls :: [DataCon] -> IO ItblEnv
1155 make_constr_itbls cons
1157 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1158 return (listToFM is)
1160 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1161 return (listToFM is)
1163 mk_vecret_itbl (dcon, conNo)
1164 = mk_itbl dcon conNo (vecret_entry conNo)
1165 mk_dirret_itbl (dcon, conNo)
1166 = mk_itbl dcon conNo mci_constr_entry
1168 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
1169 mk_itbl dcon conNo entry_addr
1170 = let (tot_wds, ptr_wds, _)
1171 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1173 nptrs = tot_wds - ptr_wds
1174 itbl = StgInfoTable {
1175 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1176 tipe = fromIntegral cONSTR,
1177 srtlen = fromIntegral conNo,
1178 code0 = fromIntegral code0, code1 = fromIntegral code1,
1179 code2 = fromIntegral code2, code3 = fromIntegral code3,
1180 code4 = fromIntegral code4, code5 = fromIntegral code5,
1181 code6 = fromIntegral code6, code7 = fromIntegral code7
1183 -- Make a piece of code to jump to "entry_label".
1184 -- This is the only arch-dependent bit.
1185 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1186 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1188 -- B8 ZZ YY XX WW FF E0
1189 (code0,code1,code2,code3,code4,code5,code6,code7)
1190 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1191 byte 2 entry_addr_w, byte 3 entry_addr_w,
1195 entry_addr_w :: Word32
1196 entry_addr_w = fromIntegral (addrToInt entry_addr)
1199 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1200 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1201 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1203 return (toRdrName dcon, addr `plusPtr` 8)
1206 byte :: Int -> Word32 -> Word32
1207 byte 0 w = w .&. 0xFF
1208 byte 1 w = (w `shiftR` 8) .&. 0xFF
1209 byte 2 w = (w `shiftR` 16) .&. 0xFF
1210 byte 3 w = (w `shiftR` 24) .&. 0xFF
1213 vecret_entry 0 = mci_constr1_entry
1214 vecret_entry 1 = mci_constr2_entry
1215 vecret_entry 2 = mci_constr3_entry
1216 vecret_entry 3 = mci_constr4_entry
1217 vecret_entry 4 = mci_constr5_entry
1218 vecret_entry 5 = mci_constr6_entry
1219 vecret_entry 6 = mci_constr7_entry
1220 vecret_entry 7 = mci_constr8_entry
1222 -- entry point for direct returns for created constr itbls
1223 foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1224 -- and the 8 vectored ones
1225 foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
1226 foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
1227 foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
1228 foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
1229 foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
1230 foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
1231 foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
1232 foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1236 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1239 -- Ultra-minimalist version specially for constructors
1240 data StgInfoTable = StgInfoTable {
1245 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1249 instance Storable StgInfoTable where
1252 = (sum . map (\f -> f itbl))
1253 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1254 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1255 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1258 = (sum . map (\f -> f itbl))
1259 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1260 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1261 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1264 = do a1 <- store (ptrs itbl) (castPtr a0)
1265 a2 <- store (nptrs itbl) a1
1266 a3 <- store (tipe itbl) a2
1267 a4 <- store (srtlen itbl) a3
1268 a5 <- store (code0 itbl) a4
1269 a6 <- store (code1 itbl) a5
1270 a7 <- store (code2 itbl) a6
1271 a8 <- store (code3 itbl) a7
1272 a9 <- store (code4 itbl) a8
1273 aA <- store (code5 itbl) a9
1274 aB <- store (code6 itbl) aA
1275 aC <- store (code7 itbl) aB
1279 = do (a1,ptrs) <- load (castPtr a0)
1280 (a2,nptrs) <- load a1
1281 (a3,tipe) <- load a2
1282 (a4,srtlen) <- load a3
1283 (a5,code0) <- load a4
1284 (a6,code1) <- load a5
1285 (a7,code2) <- load a6
1286 (a8,code3) <- load a7
1287 (a9,code4) <- load a8
1288 (aA,code5) <- load a9
1289 (aB,code6) <- load aA
1290 (aC,code7) <- load aB
1291 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1292 srtlen = srtlen, tipe = tipe,
1293 code0 = code0, code1 = code1, code2 = code2,
1294 code3 = code3, code4 = code4, code5 = code5,
1295 code6 = code6, code7 = code7 }
1297 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1298 fieldSz sel x = sizeOf (sel x)
1300 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1301 fieldAl sel x = alignment (sel x)
1303 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1304 store x addr = do poke addr x
1305 return (castPtr (addr `plusPtr` sizeOf x))
1307 load :: Storable a => Ptr a -> IO (Ptr b, a)
1308 load addr = do x <- peek addr
1309 return (castPtr (addr `plusPtr` sizeOf x), x)
1311 -----------------------------------------------------------------------------q
1313 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()