2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
11 filterNameMap, -- :: [ModuleName] -> FiniteMap Name a
12 -- -> FiniteMap Name 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 - lots of assumptions about word size vs. double size etc.
47 ----------------------------------------------------------------------------- -}
49 #include "HsVersions.h"
52 import Id ( Id, idPrimRep )
55 import PrimOp ( PrimOp(..) )
56 import PrimRep ( PrimRep(..) )
57 import Literal ( Literal(..) )
58 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
59 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
60 import ClosureInfo ( mkVirtHeapOffsets )
61 import Module ( ModuleName, moduleName )
63 import Name hiding (filterNameEnv)
68 import {-# SOURCE #-} MCI_make_constr
71 import GlaExts ( Int(..) )
72 import Module ( moduleNameFS )
74 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
75 import Class ( Class, classTyCon )
79 import OccName ( occNameString )
80 import ErrUtils ( showPass, dumpIfSet_dyn )
81 import CmdLineOpts ( DynFlags, DynFlag(..) )
82 import Panic ( panic )
92 import PrelGHC --( unsafeCoerce#, dataToTag#,
93 -- indexPtrOffClosure#, indexWordOffClosure# )
94 import PrelAddr ( Addr(..) )
95 import PrelFloat ( Float(..), Double(..) )
97 -- ---------------------------------------------------------------------------
98 -- Environments needed by the linker
99 -- ---------------------------------------------------------------------------
101 type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
102 type ClosureEnv = FiniteMap Name HValue
103 emptyClosureEnv = emptyFM
105 -- remove all entries for a given set of modules from the environment
106 filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
107 filterNameMap mods env
108 = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
110 -- ---------------------------------------------------------------------------
111 -- Turn an UnlinkedIExpr into a value we can run, for the interpreter
112 -- ---------------------------------------------------------------------------
114 iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
115 iExprToHValue ie ce expr
116 = do linked_expr <- linkIExpr ie ce expr
117 return (interp linked_expr)
119 -- ---------------------------------------------------------------------------
120 -- Convert STG to an unlinked interpretable
121 -- ---------------------------------------------------------------------------
123 -- visible from outside
124 stgBindsToInterpSyn :: DynFlags
126 -> [TyCon] -> [Class]
127 -> IO ([UnlinkedIBind], ItblEnv)
128 stgBindsToInterpSyn dflags binds local_tycons local_classes
129 = do showPass dflags "StgToInterp"
130 let ibinds = concatMap (translateBind emptyUniqSet) binds
131 let tycs = local_tycons ++ map classTyCon local_classes
132 dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
133 "Convert To InterpSyn" (vcat (map pprIBind ibinds))
134 itblenv <- mkITbls tycs
135 return (ibinds, itblenv)
137 stgExprToInterpSyn :: DynFlags
140 stgExprToInterpSyn dflags expr
141 = do showPass dflags "StgToInterp"
142 let iexpr = stg2expr emptyUniqSet expr
143 dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
144 "Convert To InterpSyn" (pprIExpr iexpr)
147 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
148 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
149 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
150 where ie' = addListToUniqSet ie (map fst vs_n_es)
152 isRec (StgNonRec _ _) = False
153 isRec (StgRec _) = True
155 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
156 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
159 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
160 rhsRep = repOfStgExpr rhs
161 mkLambdas [] = rhsExpr
162 mkLambdas [v] = mkLam (repOfId v) rhsRep v rhsExpr
163 mkLambdas (v:vs) = mkLam (repOfId v) RepP v (mkLambdas vs)
164 rhs2expr ie (StgRhsCon ccs dcon args)
165 = conapp2expr ie dcon args
167 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
168 conapp2expr ie dcon args
169 = mkConApp con_rdrname reps exprs
171 con_rdrname = getName dcon
172 exprs = map (arg2expr ie) inHeapOrder
173 reps = map repOfArg inHeapOrder
174 inHeapOrder = toHeapOrder args
176 toHeapOrder :: [StgArg] -> [StgArg]
178 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
179 (rearranged, offsets) = unzip rearranged_w_offsets
183 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
185 -- Handle most common cases specially; do the rest with a generic
186 -- mechanism (deferred till later :)
187 mkConApp :: Name -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
188 mkConApp nm [] [] = ConApp nm
189 mkConApp nm [RepI] [a1] = ConAppI nm a1
190 mkConApp nm [RepP] [a1] = ConAppP nm a1
191 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
192 mkConApp nm reps args = ConAppGen nm args
194 mkLam RepP RepP = LamPP
195 mkLam RepI RepP = LamIP
196 mkLam RepP RepI = LamPI
197 mkLam RepI RepI = LamII
198 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
200 mkApp RepP RepP = AppPP
201 mkApp RepI RepP = AppIP
202 mkApp RepP RepI = AppPI
203 mkApp RepI RepI = AppII
204 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
207 repOfId = primRep2Rep . idPrimRep
212 -- genuine lifted types
215 -- all these are unboxed, fit into a word, and we assume they
216 -- all have the same call/return convention.
224 -- these are pretty dodgy: really pointers, but
225 -- we can't let the compiler build thunks with these reps.
226 ForeignObjRep -> RepP
227 StableNameRep -> RepP
235 other -> pprPanic "primRep2Rep" (ppr other)
237 repOfStgExpr :: StgExpr -> Rep
242 StgCase scrut live liveR bndr srt alts
243 -> case altRhss alts of
244 (a:_) -> repOfStgExpr a
245 [] -> panic "repOfStgExpr: no alts"
249 -> repOfApp ((deNoteType.repType.idType) var) (length args)
251 StgPrimApp op args res_ty
252 -> (primRep2Rep.typePrimRep) res_ty
254 StgLet binds body -> repOfStgExpr body
255 StgLetNoEscape live liveR binds body -> repOfStgExpr body
257 StgConApp con args -> RepP -- by definition
260 -> pprPanic "repOfStgExpr" (ppr other)
262 altRhss (StgAlgAlts tycon alts def)
263 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
264 altRhss (StgPrimAlts tycon alts def)
265 = [rhs | (lit,rhs) <- alts] ++ defRhs def
268 defRhs (StgBindDefault rhs)
271 -- returns the Rep of the result of applying ty to n args.
272 repOfApp :: Type -> Int -> Rep
273 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
274 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
286 MachStr _ -> RepI -- because it's a ptr outside the heap
287 other -> pprPanic "repOfLit" (ppr lit)
289 lit2expr :: Literal -> UnlinkedIExpr
292 MachInt i -> case fromIntegral i of I# i -> LitI i
293 MachWord i -> case fromIntegral i of I# i -> LitI i
294 MachAddr i -> case fromIntegral i of I# i -> LitI i
295 MachChar i -> case fromIntegral i of I# i -> LitI i
296 MachFloat f -> case fromRational f of F# f -> LitF f
297 MachDouble f -> case fromRational f of D# f -> LitD f
300 CharStr s i -> LitI (addr2Int# s)
303 -- sigh, a string in the heap is no good to us. We need a
304 -- static C pointer, since the type of a string literal is
305 -- Addr#. So, copy the string into C land and introduce a
306 -- memory leak at the same time.
308 -- CAREFUL! Chars are 32 bits in ghc 4.09+
309 case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
310 strncpy a ba (fromIntegral n)
311 writeCharOffAddr addr n '\0'
313 of A# a -> LitI (addr2Int# a)
315 _ -> error "StgInterp.lit2expr: unhandled string constant type"
317 other -> pprPanic "lit2expr" (ppr lit)
319 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
323 -> mkVar ie (repOfId var) var
326 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
330 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
331 | repOfStgExpr scrut /= RepP
332 -> mkCasePrim (repOfStgExpr stgexpr)
333 bndr (stg2expr ie scrut)
334 (map (doPrimAlt ie') alts)
337 pprPanic "stg2expr(StgCase,prim)" (ppr (repOfStgExpr scrut) $$ (case scrut of (StgApp v _) -> ppr v <+> ppr (idType v) <+> ppr (idPrimRep v)) $$ ppr stgexpr)
338 where ie' = addOneToUniqSet ie bndr
340 StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
341 | repOfStgExpr scrut == RepP
342 -> mkCaseAlg (repOfStgExpr stgexpr)
343 bndr (stg2expr ie scrut)
344 (map (doAlgAlt ie') alts)
346 where ie' = addOneToUniqSet ie bndr
349 StgPrimApp op args res_ty
350 -> mkPrimOp (repOfStgExpr stgexpr) op (map (arg2expr ie) args)
353 -> conapp2expr ie dcon args
355 StgLet binds@(StgNonRec v e) body
356 -> mkNonRec (repOfStgExpr stgexpr)
357 (head (translateBind ie binds))
358 (stg2expr (addOneToUniqSet ie v) body)
360 StgLet binds@(StgRec bs) body
361 -> mkRec (repOfStgExpr stgexpr)
362 (translateBind ie binds)
363 (stg2expr (addListToUniqSet ie (map fst bs)) body)
365 -- treat let-no-escape just like let.
366 StgLetNoEscape _ _ binds body
367 -> stg2expr ie (StgLet binds body)
370 -> pprPanic "stg2expr" (ppr stgexpr)
372 doPrimAlt ie (lit,rhs)
373 = AltPrim (lit2expr lit) (stg2expr ie rhs)
374 doAlgAlt ie (dcon,vars,uses,rhs)
375 = AltAlg (dataConTag dcon - 1)
376 (map id2VaaRep (toHeapOrder vars))
377 (stg2expr (addListToUniqSet ie vars) rhs)
380 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
381 (rearranged,offsets) = unzip rearranged_w_offsets
385 def2expr ie StgNoDefault = Nothing
386 def2expr ie (StgBindDefault rhs) = Just (stg2expr ie rhs)
388 mkAppChain ie result_rep so_far []
390 mkAppChain ie result_rep so_far [a]
391 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
392 mkAppChain ie result_rep so_far (a:as)
393 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
395 mkCasePrim RepI = CasePrimI
396 mkCasePrim RepP = CasePrimP
398 mkCaseAlg RepI = CaseAlgI
399 mkCaseAlg RepP = CaseAlgP
401 -- any var that isn't in scope is turned into a Native
403 | var `elementOfUniqSet` ie =
409 | otherwise = Native (getName var)
413 mkNonRec RepI = NonRecI
414 mkNonRec RepP = NonRecP
416 mkPrimOp RepI = PrimOpI
417 mkPrimOp RepP = PrimOpP
419 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
420 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
421 arg2expr ie (StgLitArg lit) = lit2expr lit
422 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
424 repOfArg :: StgArg -> Rep
425 repOfArg (StgVarArg v) = repOfId v
426 repOfArg (StgLitArg lit) = repOfLit lit
427 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
429 id2VaaRep var = (var, repOfId var)
432 -- ---------------------------------------------------------------------------
433 -- Link interpretables into something we can run
434 -- ---------------------------------------------------------------------------
436 GLOBAL_VAR(cafTable, [], [HValue])
438 addCAF :: HValue -> IO ()
439 addCAF x = do xs <- readIORef cafTable; writeIORef cafTable (x:xs)
441 linkIModules :: ItblEnv -- incoming global itbl env; returned updated
442 -> ClosureEnv -- incoming global closure env; returned updated
443 -> [([UnlinkedIBind], ItblEnv)]
444 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
445 linkIModules gie gce mods = do
446 let (bindss, ies) = unzip mods
447 binds = concat bindss
448 top_level_binders = map (getName.binder) binds
449 final_gie = foldr plusFM gie ies
451 (new_binds, new_gce) <-
452 fixIO (\ ~(new_binds, new_gce) -> do
454 new_binds <- linkIBinds final_gie new_gce binds
456 let new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
457 let new_gce = addListToFM gce (zip top_level_binders new_rhss)
459 return (new_binds, new_gce))
461 return (new_binds, final_gie, new_gce)
464 -- We're supposed to augment the environments with the values of any
465 -- external functions/info tables we need as we go along, but that's a
466 -- lot of hassle so for now I'll look up external things as they crop
467 -- up and not cache them in the source symbol tables. The interpreted
468 -- code will still be referenced in the source symbol tables.
470 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> IO [LinkedIBind]
471 linkIBinds ie ce binds = mapM (linkIBind ie ce) binds
473 linkIBind ie ce (IBind bndr expr)
474 = do expr <- linkIExpr ie ce expr
475 return (IBind bndr expr)
477 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO LinkedIExpr
478 linkIExpr ie ce expr = case expr of
480 CaseAlgP bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgP
481 CaseAlgI bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgI
482 CaseAlgF bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgF
483 CaseAlgD bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgD
485 CasePrimP bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimP
486 CasePrimI bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimI
487 CasePrimF bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimF
488 CasePrimD bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimD
490 ConApp con -> lookupNullaryCon ie con
492 ConAppI con arg0 -> do
493 con' <- lookupCon ie con
494 arg' <- linkIExpr ie ce arg0
495 return (ConAppI con' arg')
497 ConAppP con arg0 -> do
498 con' <- lookupCon ie con
499 arg' <- linkIExpr ie ce arg0
500 return (ConAppP con' arg')
502 ConAppPP con arg0 arg1 -> do
503 con' <- lookupCon ie con
504 arg0' <- linkIExpr ie ce arg0
505 arg1' <- linkIExpr ie ce arg1
506 return (ConAppPP con' arg0' arg1')
508 ConAppGen con args -> do
509 con <- lookupCon ie con
510 args <- mapM (linkIExpr ie ce) args
511 return (ConAppGen con args)
513 PrimOpI op args -> linkPrimOp ie ce PrimOpI op args
514 PrimOpP op args -> linkPrimOp ie ce PrimOpP op args
516 NonRecP bind expr -> linkNonRec ie ce NonRecP bind expr
517 NonRecI bind expr -> linkNonRec ie ce NonRecI bind expr
518 NonRecF bind expr -> linkNonRec ie ce NonRecF bind expr
519 NonRecD bind expr -> linkNonRec ie ce NonRecD bind expr
521 RecP binds expr -> linkRec ie ce RecP binds expr
522 RecI binds expr -> linkRec ie ce RecI binds expr
523 RecF binds expr -> linkRec ie ce RecF binds expr
524 RecD binds expr -> linkRec ie ce RecD binds expr
526 LitI i -> return (LitI i)
527 LitF i -> return (LitF i)
528 LitD i -> return (LitD i)
530 Native var -> lookupNative ce var
532 VarP v -> lookupVar ce VarP v
533 VarI v -> lookupVar ce VarI v
534 VarF v -> lookupVar ce VarF v
535 VarD v -> lookupVar ce VarD v
537 LamPP bndr expr -> linkLam ie ce LamPP bndr expr
538 LamPI bndr expr -> linkLam ie ce LamPI bndr expr
539 LamPF bndr expr -> linkLam ie ce LamPF bndr expr
540 LamPD bndr expr -> linkLam ie ce LamPD bndr expr
541 LamIP bndr expr -> linkLam ie ce LamIP bndr expr
542 LamII bndr expr -> linkLam ie ce LamII bndr expr
543 LamIF bndr expr -> linkLam ie ce LamIF bndr expr
544 LamID bndr expr -> linkLam ie ce LamID bndr expr
545 LamFP bndr expr -> linkLam ie ce LamFP bndr expr
546 LamFI bndr expr -> linkLam ie ce LamFI bndr expr
547 LamFF bndr expr -> linkLam ie ce LamFF bndr expr
548 LamFD bndr expr -> linkLam ie ce LamFD bndr expr
549 LamDP bndr expr -> linkLam ie ce LamDP bndr expr
550 LamDI bndr expr -> linkLam ie ce LamDI bndr expr
551 LamDF bndr expr -> linkLam ie ce LamDF bndr expr
552 LamDD bndr expr -> linkLam ie ce LamDD bndr expr
554 AppPP fun arg -> linkApp ie ce AppPP fun arg
555 AppPI fun arg -> linkApp ie ce AppPI fun arg
556 AppPF fun arg -> linkApp ie ce AppPF fun arg
557 AppPD fun arg -> linkApp ie ce AppPD fun arg
558 AppIP fun arg -> linkApp ie ce AppIP fun arg
559 AppII fun arg -> linkApp ie ce AppII fun arg
560 AppIF fun arg -> linkApp ie ce AppIF fun arg
561 AppID fun arg -> linkApp ie ce AppID fun arg
562 AppFP fun arg -> linkApp ie ce AppFP fun arg
563 AppFI fun arg -> linkApp ie ce AppFI fun arg
564 AppFF fun arg -> linkApp ie ce AppFF fun arg
565 AppFD fun arg -> linkApp ie ce AppFD fun arg
566 AppDP fun arg -> linkApp ie ce AppDP fun arg
567 AppDI fun arg -> linkApp ie ce AppDI fun arg
568 AppDF fun arg -> linkApp ie ce AppDF fun arg
569 AppDD fun arg -> linkApp ie ce AppDD fun arg
571 linkAlgCase ie ce bndr expr alts dflt con
572 = do expr <- linkIExpr ie ce expr
573 alts <- mapM (linkAlgAlt ie ce) alts
574 dflt <- linkDefault ie ce dflt
575 return (con bndr expr alts dflt)
577 linkPrimCase ie ce bndr expr alts dflt con
578 = do expr <- linkIExpr ie ce expr
579 alts <- mapM (linkPrimAlt ie ce) alts
580 dflt <- linkDefault ie ce dflt
581 return (con bndr expr alts dflt)
583 linkAlgAlt ie ce (AltAlg tag args rhs)
584 = do rhs <- linkIExpr ie ce rhs
585 return (AltAlg tag args rhs)
587 linkPrimAlt ie ce (AltPrim lit rhs)
588 = do rhs <- linkIExpr ie ce rhs
589 lit <- linkIExpr ie ce lit
590 return (AltPrim lit rhs)
592 linkDefault ie ce Nothing = return Nothing
593 linkDefault ie ce (Just expr)
594 = do expr <- linkIExpr ie ce expr
597 linkNonRec ie ce con bind expr
598 = do expr <- linkIExpr ie ce expr
599 bind <- linkIBind ie ce bind
600 return (con bind expr)
602 linkRec ie ce con binds expr
603 = do expr <- linkIExpr ie ce expr
604 binds <- linkIBinds ie ce binds
605 return (con binds expr)
607 linkLam ie ce con bndr expr
608 = do expr <- linkIExpr ie ce expr
609 return (con bndr expr)
611 linkApp ie ce con fun arg
612 = do fun <- linkIExpr ie ce fun
613 arg <- linkIExpr ie ce arg
616 linkPrimOp ie ce con op args
617 = do args <- mapM (linkIExpr ie ce) args
621 case lookupFM ie con of
622 Just (Ptr addr) -> return addr
624 -- try looking up in the object files.
625 m <- lookupSymbol (nameToCLabel con "con_info")
627 Just addr -> return addr
628 Nothing -> pprPanic "linkIExpr" (ppr con)
630 -- nullary constructors don't have normal _con_info tables.
631 lookupNullaryCon ie con =
632 case lookupFM ie con of
633 Just (Ptr addr) -> return (ConApp addr)
635 -- try looking up in the object files.
636 m <- lookupSymbol (nameToCLabel con "closure")
638 Just (A# addr) -> return (Native (unsafeCoerce# addr))
639 Nothing -> pprPanic "lookupNullaryCon" (ppr con)
642 lookupNative ce var =
643 unsafeInterleaveIO (do
644 case lookupFM ce var of
645 Just e -> return (Native e)
647 -- try looking up in the object files.
648 let lbl = (nameToCLabel var "closure")
649 m <- lookupSymbol lbl
652 -> do addCAF (unsafeCoerce# addr)
653 return (Native (unsafeCoerce# addr))
654 Nothing -> pprPanic "linkIExpr" (ppr var)
657 -- some VarI/VarP refer to top-level interpreted functions; we change
658 -- them into Natives here.
661 case lookupFM ce (getName v) of
662 Nothing -> return (f v)
663 Just e -> return (Native e)
666 -- HACK!!! ToDo: cleaner
667 nameToCLabel :: Name -> String{-suffix-} -> String
668 nameToCLabel n suffix =
669 _UNPK_(moduleNameFS (rdrNameModule rn))
670 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
671 where rn = toRdrName n
673 -- ---------------------------------------------------------------------------
674 -- The interpreter proper
675 -- ---------------------------------------------------------------------------
677 -- The dynamic environment contains everything boxed.
678 -- eval* functions which look up values in it will know the
679 -- representation of the thing they are looking up, so they
680 -- can cast/unbox it as necessary.
682 -- ---------------------------------------------------------------------------
683 -- Evaluator for things of boxed (pointer) representation
684 -- ---------------------------------------------------------------------------
686 interp :: LinkedIExpr -> HValue
687 interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
689 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
693 -- | trace ("evalP: " ++ showExprTag expr) False
694 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
695 = error "evalP: ?!?!"
698 evalP (Native p) de = unsafeCoerce# p
700 -- First try the dynamic env. If that fails, assume it's a top-level
701 -- binding and look in the static env. That gives an Expr, which we
702 -- must convert to a boxed thingy by applying evalP to it. Because
703 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
704 -- CAFs), it's always safe to use evalP.
706 = case lookupUFM de v of
708 Nothing -> error ("evalP: lookupUFM " ++ show v)
710 -- Deal with application of a function returning a pointer rep
711 -- to arguments of any persuasion. Note that the function itself
712 -- always has pointer rep.
713 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
714 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
715 evalP (AppFP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de)
716 evalP (AppDP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de)
718 -- Lambdas always return P-rep, but we need to do different things
719 -- depending on both the argument and result representations.
721 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
723 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
725 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
727 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
729 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
731 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
733 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
735 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
737 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
739 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
741 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
743 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
745 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
747 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
749 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
751 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
754 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
755 -- except in the sense that we go on and evaluate the body with whichever
756 -- evaluator was used for the expression as a whole.
757 evalP (NonRecP bind e) de
758 = evalP e (augment_nonrec bind de)
759 evalP (RecP binds b) de
760 = evalP b (augment_rec binds de)
761 evalP (CaseAlgP bndr expr alts def) de
762 = case helper_caseAlg bndr expr alts def de of
763 (rhs, de') -> evalP rhs de'
764 evalP (CasePrimP bndr expr alts def) de
765 = case helper_casePrim bndr expr alts def de of
766 (rhs, de') -> evalP rhs de'
768 evalP (ConApp (A# itbl)) de
769 = mci_make_constr0 itbl
771 evalP (ConAppI (A# itbl) a1) de
772 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
774 evalP (ConAppP (A# itbl) a1) de
775 = evalP (ConAppGen (A# itbl) [a1]) de
776 -- = let p1 = evalP a1 de
777 -- in mci_make_constrP itbl p1
779 evalP (ConAppPP (A# itbl) a1 a2) de
780 = let p1 = evalP a1 de
782 in mci_make_constrPP itbl p1 p2
784 evalP (ConAppGen itbl args) de
785 = let c = case itbl of A# a# -> mci_make_constr a# in
786 c `seq` loop c 1#{-leave room for hdr-} args
788 loop :: a{-closure-} -> Int# -> [LinkedIExpr] -> a
792 RepP -> let c' = setPtrOffClosure c off (evalP a de)
793 in c' `seq` loop c' (off +# 1#) as
794 RepI -> case evalI a de of { i# ->
795 let c' = setIntOffClosure c off i#
796 in c' `seq` loop c' (off +# 1#) as }
797 RepF -> case evalF a de of { f# ->
798 let c' = setFloatOffClosure c off f#
799 in c' `seq` loop c' (off +# 1#) as }
800 RepD -> case evalD a de of { d# ->
801 let c' = setDoubleOffClosure c off d#
802 in c' `seq` loop c' (off +# 2#) as }
804 evalP (PrimOpP IntEqOp [e1,e2]) de
805 = case evalI e1 de of
806 i1# -> case evalI e2 de of
807 i2# -> unsafeCoerce# (i1# ==# i2#)
809 evalP (PrimOpP primop _) de
810 = error ("evalP: unhandled primop: " ++ showSDoc (ppr primop))
812 = error ("evalP: unhandled case: " ++ showExprTag other)
814 --------------------------------------------------------
815 --- Evaluator for things of Int# representation
816 --------------------------------------------------------
818 -- Evaluate something which has an unboxed Int rep
819 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
823 -- | trace ("evalI: " ++ showExprTag expr) False
824 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
825 = error "evalI: ?!?!"
828 evalI (LitI i#) de = i#
831 case lookupUFM de v of
832 Just e -> case unsafeCoerce# e of I# i -> i
833 Nothing -> error ("evalI: 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 evalI (AppII e1 e2) de
839 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
840 evalI (AppPI e1 e2) de
841 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
842 evalI (AppFI e1 e2) de
843 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
844 evalI (AppDI 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 evalI (NonRecI bind b) de
851 = evalI b (augment_nonrec bind de)
852 evalI (RecI binds b) de
853 = evalI b (augment_rec binds de)
854 evalI (CaseAlgI bndr expr alts def) de
855 = case helper_caseAlg bndr expr alts def de of
856 (rhs, de') -> evalI rhs de'
857 evalI (CasePrimI bndr expr alts def) de
858 = case helper_casePrim bndr expr alts def de of
859 (rhs, de') -> evalI rhs de'
861 -- evalI can't be applied to a lambda term, by defn, since those
864 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
865 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
866 evalI (PrimOpI DataToTagOp [e1]) de = dataToTag# (evalP e1 de)
868 evalI (PrimOpI primop _) de
869 = error ("evalI: unhandled primop: " ++ showSDoc (ppr primop))
871 --evalI (NonRec (IBind v e) b) de
872 -- = evalI b (augment de v (eval e de))
875 = error ("evalI: unhandled case: " ++ showExprTag other)
877 --------------------------------------------------------
878 --- Evaluator for things of Float# representation
879 --------------------------------------------------------
881 -- Evaluate something which has an unboxed Int rep
882 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
886 -- | trace ("evalF: " ++ showExprTag expr) False
887 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
888 = error "evalF: ?!?!"
891 evalF (LitF f#) de = f#
894 case lookupUFM de v of
895 Just e -> case unsafeCoerce# e of F# i -> i
896 Nothing -> error ("evalF: lookupUFM " ++ show v)
898 -- Deal with application of a function returning an Int# rep
899 -- to arguments of any persuasion. Note that the function itself
900 -- always has pointer rep.
901 evalF (AppIF e1 e2) de
902 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
903 evalF (AppPF e1 e2) de
904 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
905 evalF (AppFF e1 e2) de
906 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
907 evalF (AppDF e1 e2) de
908 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
910 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
911 -- except in the sense that we go on and evaluate the body with whichever
912 -- evaluator was used for the expression as a whole.
913 evalF (NonRecF bind b) de
914 = evalF b (augment_nonrec bind de)
915 evalF (RecF binds b) de
916 = evalF b (augment_rec binds de)
917 evalF (CaseAlgF bndr expr alts def) de
918 = case helper_caseAlg bndr expr alts def de of
919 (rhs, de') -> evalF rhs de'
920 evalF (CasePrimF bndr expr alts def) de
921 = case helper_casePrim bndr expr alts def de of
922 (rhs, de') -> evalF rhs de'
924 -- evalF can't be applied to a lambda term, by defn, since those
927 evalF (PrimOpF op _) de
928 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
931 = error ("evalF: unhandled case: " ++ showExprTag other)
933 --------------------------------------------------------
934 --- Evaluator for things of Double# representation
935 --------------------------------------------------------
937 -- Evaluate something which has an unboxed Int rep
938 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
942 -- | trace ("evalD: " ++ showExprTag expr) False
943 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
944 = error "evalD: ?!?!"
947 evalD (LitD d#) de = d#
950 case lookupUFM de v of
951 Just e -> case unsafeCoerce# e of D# i -> i
952 Nothing -> error ("evalD: lookupUFM " ++ show v)
954 -- Deal with application of a function returning an Int# rep
955 -- to arguments of any persuasion. Note that the function itself
956 -- always has pointer rep.
957 evalD (AppID e1 e2) de
958 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
959 evalD (AppPD e1 e2) de
960 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
961 evalD (AppFD e1 e2) de
962 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
963 evalD (AppDD e1 e2) de
964 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
966 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
967 -- except in the sense that we go on and evaluate the body with whichever
968 -- evaluator was used for the expression as a whole.
969 evalD (NonRecD bind b) de
970 = evalD b (augment_nonrec bind de)
971 evalD (RecD binds b) de
972 = evalD b (augment_rec binds de)
973 evalD (CaseAlgD bndr expr alts def) de
974 = case helper_caseAlg bndr expr alts def de of
975 (rhs, de') -> evalD rhs de'
976 evalD (CasePrimD bndr expr alts def) de
977 = case helper_casePrim bndr expr alts def de of
978 (rhs, de') -> evalD rhs de'
980 -- evalD can't be applied to a lambda term, by defn, since those
983 evalD (PrimOpD op _) de
984 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
987 = error ("evalD: unhandled case: " ++ showExprTag other)
989 --------------------------------------------------------
990 --- Helper bits and pieces
991 --------------------------------------------------------
993 -- Find the Rep of any Expr
994 repOf :: LinkedIExpr -> Rep
996 repOf (LamPP _ _) = RepP
997 repOf (LamPI _ _) = RepP
998 repOf (LamPF _ _) = RepP
999 repOf (LamPD _ _) = RepP
1000 repOf (LamIP _ _) = RepP
1001 repOf (LamII _ _) = RepP
1002 repOf (LamIF _ _) = RepP
1003 repOf (LamID _ _) = RepP
1004 repOf (LamFP _ _) = RepP
1005 repOf (LamFI _ _) = RepP
1006 repOf (LamFF _ _) = RepP
1007 repOf (LamFD _ _) = RepP
1008 repOf (LamDP _ _) = RepP
1009 repOf (LamDI _ _) = RepP
1010 repOf (LamDF _ _) = RepP
1011 repOf (LamDD _ _) = RepP
1013 repOf (AppPP _ _) = RepP
1014 repOf (AppPI _ _) = RepI
1015 repOf (AppPF _ _) = RepF
1016 repOf (AppPD _ _) = RepD
1017 repOf (AppIP _ _) = RepP
1018 repOf (AppII _ _) = RepI
1019 repOf (AppIF _ _) = RepF
1020 repOf (AppID _ _) = RepD
1021 repOf (AppFP _ _) = RepP
1022 repOf (AppFI _ _) = RepI
1023 repOf (AppFF _ _) = RepF
1024 repOf (AppFD _ _) = RepD
1025 repOf (AppDP _ _) = RepP
1026 repOf (AppDI _ _) = RepI
1027 repOf (AppDF _ _) = RepF
1028 repOf (AppDD _ _) = RepD
1030 repOf (NonRecP _ _) = RepP
1031 repOf (NonRecI _ _) = RepI
1032 repOf (NonRecF _ _) = RepF
1033 repOf (NonRecD _ _) = RepD
1035 repOf (RecP _ _) = RepP
1036 repOf (RecI _ _) = RepI
1037 repOf (RecF _ _) = RepF
1038 repOf (RecD _ _) = RepD
1040 repOf (LitI _) = RepI
1041 repOf (LitF _) = RepF
1042 repOf (LitD _) = RepD
1044 repOf (Native _) = RepP
1046 repOf (VarP _) = RepP
1047 repOf (VarI _) = RepI
1048 repOf (VarF _) = RepF
1049 repOf (VarD _) = RepD
1051 repOf (PrimOpP _ _) = RepP
1052 repOf (PrimOpI _ _) = RepI
1053 repOf (PrimOpF _ _) = RepF
1054 repOf (PrimOpD _ _) = RepD
1056 repOf (ConApp _) = RepP
1057 repOf (ConAppI _ _) = RepP
1058 repOf (ConAppP _ _) = RepP
1059 repOf (ConAppPP _ _ _) = RepP
1060 repOf (ConAppGen _ _) = RepP
1062 repOf (CaseAlgP _ _ _ _) = RepP
1063 repOf (CaseAlgI _ _ _ _) = RepI
1064 repOf (CaseAlgF _ _ _ _) = RepF
1065 repOf (CaseAlgD _ _ _ _) = RepD
1067 repOf (CasePrimP _ _ _ _) = RepP
1068 repOf (CasePrimI _ _ _ _) = RepI
1069 repOf (CasePrimF _ _ _ _) = RepF
1070 repOf (CasePrimD _ _ _ _) = RepD
1073 = error ("repOf: unhandled case: " ++ showExprTag other)
1075 -- how big (in words) is one of these
1076 repSizeW :: Rep -> Int
1081 -- Evaluate an expression, using the appropriate evaluator,
1082 -- then box up the result. Note that it's only safe to use this
1083 -- to create values to put in the environment. You can't use it
1084 -- to create a value which might get passed to native code since that
1085 -- code will have no idea that unboxed things have been boxed.
1086 eval :: LinkedIExpr -> UniqFM boxed -> boxed
1088 = case repOf expr of
1089 RepI -> unsafeCoerce# (I# (evalI expr de))
1090 RepP -> evalP expr de
1091 RepF -> unsafeCoerce# (F# (evalF expr de))
1092 RepD -> unsafeCoerce# (D# (evalD expr de))
1094 -- Evaluate the scrutinee of a case, select an alternative,
1095 -- augment the environment appropriately, and return the alt
1096 -- and the augmented environment.
1097 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
1099 -> (LinkedIExpr, UniqFM boxed)
1100 helper_caseAlg bndr expr alts def de
1101 = let exprEv = evalP expr de
1103 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
1104 case select_altAlg (tagOf exprEv) alts def of
1105 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
1108 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
1110 -> (LinkedIExpr, UniqFM boxed)
1111 helper_casePrim bndr expr alts def de
1112 = case repOf expr of
1113 RepI -> case evalI expr de of
1114 i# -> (select_altPrim alts def (LitI i#),
1115 addToUFM de bndr (unsafeCoerce# (I# i#)))
1116 RepF -> case evalF expr de of
1117 f# -> (select_altPrim alts def (LitF f#),
1118 addToUFM de bndr (unsafeCoerce# (F# f#)))
1119 RepD -> case evalD expr de of
1120 d# -> (select_altPrim alts def (LitD d#),
1121 addToUFM de bndr (unsafeCoerce# (D# d#)))
1124 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
1125 augment_from_constr de con ([],offset)
1127 augment_from_constr de con ((v,rep):vs,offset)
1130 RepP -> indexPtrOffClosure con offset
1131 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1132 RepF -> unsafeCoerce# (F# (indexFloatOffClosure con offset))
1133 RepD -> unsafeCoerce# (D# (indexDoubleOffClosure con offset))
1135 augment_from_constr (addToUFM de v v_binding) con
1136 (vs,offset + repSizeW rep)
1138 -- Augment the environment for a non-recursive let.
1139 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1140 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1142 -- Augment the environment for a recursive let.
1143 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1144 augment_rec binds de
1145 = let vars = map binder binds
1146 rhss = map bindee binds
1147 rhs_vs = map (\rhs -> eval rhs de') rhss
1148 de' = addListToUFM de (zip vars rhs_vs)
1152 -- a must be a constructor?
1154 tagOf x = I# (dataToTag# x)
1156 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1157 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1158 select_altAlg tag [] (Just def) = ([],def)
1159 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1162 else select_altAlg tag alts def
1164 -- literal may only be a literal, not an arbitrary expression
1165 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1166 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1167 select_altPrim [] (Just def) literal = def
1168 select_altPrim ((AltPrim lit rhs):alts) def literal
1169 = if eqLits lit literal
1171 else select_altPrim alts def literal
1173 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1175 -- ----------------------------------------------------------------------
1176 -- Grotty inspection and creation of closures
1177 -- ----------------------------------------------------------------------
1179 -- a is a constructor
1180 indexPtrOffClosure :: a -> Int -> b
1181 indexPtrOffClosure con (I# offset)
1182 = case indexPtrOffClosure# con offset of (# x #) -> x
1184 indexIntOffClosure :: a -> Int -> Int#
1185 indexIntOffClosure con (I# offset)
1186 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1188 indexFloatOffClosure :: a -> Int -> Float#
1189 indexFloatOffClosure con (I# offset)
1190 = unsafeCoerce# (indexWordOffClosure# con offset)
1191 -- TOCK TOCK TOCK! Those GHC developers are crazy.
1193 indexDoubleOffClosure :: a -> Int -> Double#
1194 indexDoubleOffClosure con (I# offset)
1195 = unsafeCoerce# (panic "indexDoubleOffClosure")
1197 setPtrOffClosure :: a -> Int# -> b -> a
1198 setPtrOffClosure a i b = case setPtrOffClosure# a i b of (# c #) -> c
1200 setIntOffClosure :: a -> Int# -> Int# -> a
1201 setIntOffClosure a i b = case setWordOffClosure# a i (int2Word# b) of (# c #) -> c
1203 setFloatOffClosure :: a -> Int# -> Float# -> a
1204 setFloatOffClosure a i b = case setWordOffClosure# a i (unsafeCoerce# b) of (# c #) -> c
1206 setDoubleOffClosure :: a -> Int# -> Double# -> a
1207 setDoubleOffClosure a i b = unsafeCoerce# (panic "setDoubleOffClosure")
1209 ------------------------------------------------------------------------
1210 --- Manufacturing of info tables for DataCons defined in this module ---
1211 ------------------------------------------------------------------------
1213 #if __GLASGOW_HASKELL__ <= 408
1216 type ItblPtr = Ptr StgInfoTable
1219 -- Make info tables for the data decls in this module
1220 mkITbls :: [TyCon] -> IO ItblEnv
1221 mkITbls [] = return emptyFM
1222 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1223 itbls2 <- mkITbls tcs
1224 return (itbls `plusFM` itbls2)
1226 mkITbl :: TyCon -> IO ItblEnv
1228 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1230 | not (isDataTyCon tc)
1232 | n == length dcs -- paranoia; this is an assertion.
1233 = make_constr_itbls dcs
1235 dcs = tyConDataCons tc
1236 n = tyConFamilySize tc
1239 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1241 -- Assumes constructors are numbered from zero, not one
1242 make_constr_itbls :: [DataCon] -> IO ItblEnv
1243 make_constr_itbls cons
1245 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1246 return (listToFM is)
1248 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1249 return (listToFM is)
1251 mk_vecret_itbl (dcon, conNo)
1252 = mk_itbl dcon conNo (vecret_entry conNo)
1253 mk_dirret_itbl (dcon, conNo)
1254 = mk_itbl dcon conNo mci_constr_entry
1256 mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
1257 mk_itbl dcon conNo entry_addr
1258 = let (tot_wds, ptr_wds, _)
1259 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1261 nptrs = tot_wds - ptr_wds
1262 itbl = StgInfoTable {
1263 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1264 tipe = fromIntegral cONSTR,
1265 srtlen = fromIntegral conNo,
1266 code0 = fromIntegral code0, code1 = fromIntegral code1,
1267 code2 = fromIntegral code2, code3 = fromIntegral code3,
1268 code4 = fromIntegral code4, code5 = fromIntegral code5,
1269 code6 = fromIntegral code6, code7 = fromIntegral code7
1271 -- Make a piece of code to jump to "entry_label".
1272 -- This is the only arch-dependent bit.
1273 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1274 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1276 -- B8 ZZ YY XX WW FF E0
1277 (code0,code1,code2,code3,code4,code5,code6,code7)
1278 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1279 byte 2 entry_addr_w, byte 3 entry_addr_w,
1283 entry_addr_w :: Word32
1284 entry_addr_w = fromIntegral (addrToInt entry_addr)
1287 --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1288 --putStrLn ("# ptrs of itbl is " ++ show ptrs)
1289 --putStrLn ("# nptrs of itbl is " ++ show nptrs)
1291 return (getName dcon, addr `plusPtr` 8)
1294 byte :: Int -> Word32 -> Word32
1295 byte 0 w = w .&. 0xFF
1296 byte 1 w = (w `shiftR` 8) .&. 0xFF
1297 byte 2 w = (w `shiftR` 16) .&. 0xFF
1298 byte 3 w = (w `shiftR` 24) .&. 0xFF
1301 vecret_entry 0 = mci_constr1_entry
1302 vecret_entry 1 = mci_constr2_entry
1303 vecret_entry 2 = mci_constr3_entry
1304 vecret_entry 3 = mci_constr4_entry
1305 vecret_entry 4 = mci_constr5_entry
1306 vecret_entry 5 = mci_constr6_entry
1307 vecret_entry 6 = mci_constr7_entry
1308 vecret_entry 7 = mci_constr8_entry
1310 -- entry point for direct returns for created constr itbls
1311 foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1312 -- and the 8 vectored ones
1313 foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
1314 foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
1315 foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
1316 foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
1317 foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
1318 foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
1319 foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
1320 foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1324 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1327 -- Ultra-minimalist version specially for constructors
1328 data StgInfoTable = StgInfoTable {
1333 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1337 instance Storable StgInfoTable where
1340 = (sum . map (\f -> f itbl))
1341 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1342 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1343 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1346 = (sum . map (\f -> f itbl))
1347 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1348 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1349 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1352 = do a1 <- store (ptrs itbl) (castPtr a0)
1353 a2 <- store (nptrs itbl) a1
1354 a3 <- store (tipe itbl) a2
1355 a4 <- store (srtlen itbl) a3
1356 a5 <- store (code0 itbl) a4
1357 a6 <- store (code1 itbl) a5
1358 a7 <- store (code2 itbl) a6
1359 a8 <- store (code3 itbl) a7
1360 a9 <- store (code4 itbl) a8
1361 aA <- store (code5 itbl) a9
1362 aB <- store (code6 itbl) aA
1363 aC <- store (code7 itbl) aB
1367 = do (a1,ptrs) <- load (castPtr a0)
1368 (a2,nptrs) <- load a1
1369 (a3,tipe) <- load a2
1370 (a4,srtlen) <- load a3
1371 (a5,code0) <- load a4
1372 (a6,code1) <- load a5
1373 (a7,code2) <- load a6
1374 (a8,code3) <- load a7
1375 (a9,code4) <- load a8
1376 (aA,code5) <- load a9
1377 (aB,code6) <- load aA
1378 (aC,code7) <- load aB
1379 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1380 srtlen = srtlen, tipe = tipe,
1381 code0 = code0, code1 = code1, code2 = code2,
1382 code3 = code3, code4 = code4, code5 = code5,
1383 code6 = code6, code7 = code7 }
1385 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1386 fieldSz sel x = sizeOf (sel x)
1388 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1389 fieldAl sel x = alignment (sel x)
1391 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1392 store x addr = do poke addr x
1393 return (castPtr (addr `plusPtr` sizeOf x))
1395 load :: Storable a => Ptr a -> IO (Ptr b, a)
1396 load addr = do x <- peek addr
1397 return (castPtr (addr `plusPtr` sizeOf x), x)
1399 -----------------------------------------------------------------------------q
1401 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()