2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
11 linkIModules, -- :: ItblEnv -> ClosureEnv -> [[UnlinkedIBind]] ->
12 -- ([LinkedIBind], ItblEnv, ClosureEnv)
14 runStgI -- tmp, for testing
17 {- -----------------------------------------------------------------------------
20 - link should be in the IO monad, so it can modify the symtabs as it
23 - need a way to remove the bindings for a module from the symtabs.
24 maybe the symtabs should be indexed by module first.
26 - change the representation to something less verbose (?).
28 - converting string literals to Addr# is horrible and introduces
29 a memory leak. See if something can be done about this.
31 ----------------------------------------------------------------------------- -}
33 #include "HsVersions.h"
37 import Id ( Id, idPrimRep )
40 import PrimOp ( PrimOp(..) )
41 import PrimRep ( PrimRep(..) )
42 import Literal ( Literal(..) )
43 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
44 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
45 import ClosureInfo ( mkVirtHeapOffsets )
46 import Name ( toRdrName )
50 import {-# SOURCE #-} MCI_make_constr
52 import IOExts ( unsafePerformIO ) -- ToDo: remove
53 import PrelGHC --( unsafeCoerce#, dataToTag#,
54 -- indexPtrOffClosure#, indexWordOffClosure# )
55 import IO ( hPutStr, stderr )
57 import PrelAddr ( Addr(..) )
58 import PrelFloat ( Float(..), Double(..) )
64 import GlaExts ( Int(..) )
65 import Module ( moduleNameFS )
68 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
69 import Class ( Class )
73 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
75 import Panic ( panic )
76 import OccName ( occNameString )
79 -- ---------------------------------------------------------------------------
80 -- Environments needed by the linker
81 -- ---------------------------------------------------------------------------
83 type ItblEnv = FiniteMap RdrName Addr
84 type ClosureEnv = FiniteMap RdrName HValue
86 -- ---------------------------------------------------------------------------
87 -- Run our STG program through the interpreter
88 -- ---------------------------------------------------------------------------
90 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
93 runStgI = panic "StgInterp.runStgI: not implemented"
94 linkIModules = panic "StgInterp.linkIModules: not implemented"
97 -- the bindings need to have a binding for stgMain, and the
98 -- body of it had better represent something of type Int# -> Int#
99 runStgI tycons classes stgbinds
101 let unlinked_binds = concatMap (stg2IBinds emptyUniqSet) stgbinds
105 = "-------------------- Unlinked Binds --------------------\n"
106 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
109 hPutStr stderr dbg_txt
111 (linked_binds, ie, ce) <-
112 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
115 = "-------------------- Linked Binds --------------------\n"
116 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
119 hPutStr stderr dbg_txt
122 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
124 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
127 = I# (evalI (AppII stgMain (LitI 0#))
128 emptyUFM{-initial de-}
132 -- ---------------------------------------------------------------------------
133 -- Convert STG to an unlinked interpretable
134 -- ---------------------------------------------------------------------------
136 stg2IBinds :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
137 stg2IBinds ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
138 stg2IBinds ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
139 where ie' = addListToUniqSet ie (map fst vs_n_es)
141 isRec (StgNonRec _ _) = False
142 isRec (StgRec _) = True
144 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
145 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
148 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
149 rhsRep = repOfStgExpr rhs
150 mkLambdas [] = rhsExpr
151 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
152 rhs2expr ie (StgRhsCon ccs dcon args)
153 = conapp2expr ie dcon args
155 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
156 conapp2expr ie dcon args
157 = mkConApp con_rdrname reps exprs
159 con_rdrname = toRdrName dcon
160 exprs = map (arg2expr ie) inHeapOrder
161 reps = map repOfArg inHeapOrder
162 inHeapOrder = toHeapOrder args
164 toHeapOrder :: [StgArg] -> [StgArg]
166 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
167 (rearranged, offsets) = unzip rearranged_w_offsets
171 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
173 -- Handle most common cases specially; do the rest with a generic
174 -- mechanism (deferred till later :)
175 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
176 mkConApp nm [] [] = ConApp nm
177 mkConApp nm [RepI] [a1] = ConAppI nm a1
178 mkConApp nm [RepP] [a1] = ConAppP nm a1
179 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
180 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
181 mkConApp nm reps args
182 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
184 mkLam RepP RepP = LamPP
185 mkLam RepI RepP = LamIP
186 mkLam RepP RepI = LamPI
187 mkLam RepI RepI = LamII
188 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
190 mkApp RepP RepP = AppPP
191 mkApp RepI RepP = AppIP
192 mkApp RepP RepI = AppPI
193 mkApp RepI RepI = AppII
194 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
197 repOfId = primRep2Rep . idPrimRep
202 -- genuine lifted types
205 -- all these are unboxed, fit into a word, and we assume they
206 -- all have the same call/return convention.
214 -- these are pretty dodgy: really pointers, but
215 -- we can't let the compiler build thunks with these reps.
216 ForeignObjRep -> RepP
217 StableNameRep -> RepP
222 other -> pprPanic "primRep2Rep" (ppr other)
224 repOfStgExpr :: StgExpr -> Rep
229 StgCase scrut live liveR bndr srt alts
230 -> case altRhss alts of
231 (a:_) -> repOfStgExpr a
232 [] -> panic "repOfStgExpr: no alts"
236 -> repOfApp ((deNoteType.repType.idType) var) (length args)
238 StgPrimApp op args res_ty
239 -> (primRep2Rep.typePrimRep) res_ty
241 StgLet binds body -> repOfStgExpr body
242 StgLetNoEscape live liveR binds body -> repOfStgExpr body
244 StgConApp con args -> RepP -- by definition
247 -> pprPanic "repOfStgExpr" (ppr other)
249 altRhss (StgAlgAlts ty alts def)
250 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
251 altRhss (StgPrimAlts ty alts def)
252 = [rhs | (lit,rhs) <- alts] ++ defRhs def
255 defRhs (StgBindDefault rhs)
258 -- returns the Rep of the result of applying ty to n args.
259 repOfApp :: Type -> Int -> Rep
260 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
261 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
273 MachStr _ -> RepI -- because it's a ptr outside the heap
274 other -> pprPanic "repOfLit" (ppr lit)
276 lit2expr :: Literal -> UnlinkedIExpr
279 MachInt i -> case fromIntegral i of I# i -> LitI i
280 MachWord i -> case fromIntegral i of I# i -> LitI i
281 MachAddr i -> case fromIntegral i of I# i -> LitI i
282 MachChar i -> case fromIntegral i of I# i -> LitI i
283 MachFloat f -> case fromRational f of F# f -> LitF f
284 MachDouble f -> case fromRational f of D# f -> LitD f
287 CharStr s i -> LitI (addr2Int# s)
290 -- sigh, a string in the heap is no good to us. We need a
291 -- static C pointer, since the type of a string literal is
292 -- Addr#. So, copy the string into C land and introduce a
293 -- memory leak at the same time.
295 case unsafePerformIO (do a <- malloc (n+1);
296 strncpy a ba (fromIntegral n);
297 writeCharOffAddr a n '\0'
299 of A# a -> LitI (addr2Int# a)
301 _ -> error "StgInterp.lit2expr: unhandled string constant type"
303 other -> pprPanic "lit2expr" (ppr lit)
305 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
309 -> mkVar ie (repOfId var) var
312 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
316 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
317 | repOfStgExpr scrut /= RepP
318 -> mkCasePrim (repOfStgExpr stgexpr)
319 bndr (stg2expr ie scrut)
323 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
324 | repOfStgExpr scrut == RepP
325 -> mkCaseAlg (repOfStgExpr stgexpr)
326 bndr (stg2expr ie scrut)
330 StgPrimApp op args res_ty
331 -> mkPrimOp (repOfStgExpr stgexpr)
332 op (map (arg2expr ie) args)
335 -> conapp2expr ie dcon args
337 StgLet binds@(StgNonRec v e) body
338 -> mkNonRec (repOfStgExpr stgexpr)
339 (head (stg2IBinds ie binds))
340 (stg2expr (addOneToUniqSet ie v) body)
342 StgLet binds@(StgRec bs) body
343 -> mkRec (repOfStgExpr stgexpr)
344 (stg2IBinds ie binds)
345 (stg2expr (addListToUniqSet ie (map fst bs)) body)
348 -> pprPanic "stg2expr" (ppr stgexpr)
351 = AltPrim (lit2expr lit) (stg2expr ie rhs)
352 doAlgAlt (dcon,vars,uses,rhs)
353 = AltAlg (dataConTag dcon - 1)
354 (map id2VaaRep (toHeapOrder vars))
355 (stg2expr (addListToUniqSet ie vars) rhs)
358 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
359 (rearranged,offsets) = unzip rearranged_w_offsets
363 def2expr StgNoDefault = Nothing
364 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
366 mkAppChain ie result_rep so_far []
368 mkAppChain ie result_rep so_far [a]
369 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
370 mkAppChain ie result_rep so_far (a:as)
371 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
373 mkCasePrim RepI = CasePrimI
374 mkCasePrim RepP = CasePrimP
376 mkCaseAlg RepI = CaseAlgI
377 mkCaseAlg RepP = CaseAlgP
379 -- any var that isn't in scope is turned into a Native
381 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
382 | otherwise = Native (toRdrName var)
386 mkNonRec RepI = NonRecI
387 mkNonRec RepP = NonRecP
389 mkPrimOp RepI = PrimOpI
390 mkPrimOp RepP = PrimOpP
392 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
393 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
394 arg2expr ie (StgLitArg lit) = lit2expr lit
395 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
397 repOfArg :: StgArg -> Rep
398 repOfArg (StgVarArg v) = repOfId v
399 repOfArg (StgLitArg lit) = repOfLit lit
400 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
402 id2VaaRep var = (var, repOfId var)
404 -- ---------------------------------------------------------------------------
405 -- Link an interpretable into something we can run
406 -- ---------------------------------------------------------------------------
408 linkIModules :: ItblEnv -> ClosureEnv -> [([TyCon],[UnlinkedIBind])] ->
409 IO ([LinkedIBind], ItblEnv, ClosureEnv)
410 linkIModules ie ce mods = do
411 let (tyconss, bindss) = unzip mods
412 tycons = concat tyconss
413 binds = concat bindss
414 top_level_binders = map (toRdrName.binder) binds
416 new_ie <- mkITbls (concat tyconss)
417 let new_ce = addListToFM ce (zip top_level_binders new_rhss)
418 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
419 ---vvvvvvvvv--------------------------------------^^^^^^^^^-- circular
420 (new_binds, final_ie, final_ce) = linkIBinds new_ie new_ce binds
422 return (new_binds, final_ie, final_ce)
424 -- We're supposed to augment the environments with the values of any
425 -- external functions/info tables we need as we go along, but that's a
426 -- lot of hassle so for now I'll look up external things as they crop
427 -- up and not cache them in the source symbol tables. The interpreted
428 -- code will still be referenced in the source symbol tables.
431 -- Make info tables for the data decls in this module
432 mkITbls :: [TyCon] -> IO ItblEnv
433 mkITbls [] = return emptyFM
434 mkITbls (tc:tcs) = do itbls <- mkITbl tc
435 itbls2 <- mkITbls tcs
436 return (itbls `plusFM` itbls2)
438 mkITbl :: TyCon -> IO ItblEnv
440 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
442 | not (isDataTyCon tc)
444 | n == length dcs -- paranoia; this is an assertion.
445 = make_constr_itbls dcs
447 dcs = tyConDataCons tc
448 n = tyConFamilySize tc
451 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] ->
452 ([LinkedIBind], ItblEnv, ClosureEnv)
453 linkIBinds ie ce binds
454 = (new_binds, ie, ce)
455 where new_binds = map (linkIBind ie ce) binds
457 linkIBinds' ie ce binds
458 = new_binds where (new_binds, ie, ce) = linkIBinds ie ce binds
460 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
462 linkIExpr ie ce expr = case expr of
464 CaseAlgP bndr expr alts dflt ->
465 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
466 (linkDefault ie ce dflt)
468 CaseAlgI bndr expr alts dflt ->
469 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
470 (linkDefault ie ce dflt)
472 CasePrimP bndr expr alts dflt ->
473 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
474 (linkDefault ie ce dflt)
476 CasePrimI bndr expr alts dflt ->
477 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
478 (linkDefault ie ce dflt)
481 ConApp (lookupCon ie con)
484 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
487 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
489 ConAppPP con arg0 arg1 ->
490 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
492 ConAppPPP con arg0 arg1 arg2 ->
493 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
494 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
496 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
497 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
499 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
500 RecP binds expr -> RecP (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
502 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
503 RecI binds expr -> RecI (linkIBinds' ie ce binds) (linkIExpr ie ce expr)
509 Native var -> lookupNative ce var
511 VarP v -> lookupVar ce VarP v
512 VarI v -> lookupVar ce VarI v
514 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
515 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
516 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
517 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
519 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
520 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
521 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
522 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
525 case lookupFM ie con of
528 -- try looking up in the object files.
530 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
532 Nothing -> pprPanic "linkIExpr" (ppr con)
534 lookupNative ce var =
535 case lookupFM ce var of
538 -- try looking up in the object files.
539 let lbl = (rdrNameToCLabel var "closure")
540 addr = unsafePerformIO (lookupSymbol lbl) in
541 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
542 Just (A# addr) -> Native (unsafeCoerce# addr)
543 Nothing -> pprPanic "linkIExpr" (ppr var)
545 -- some VarI/VarP refer to top-level interpreted functions; we change
546 -- them into Natives here.
548 case lookupFM ce (toRdrName v) of
552 -- HACK!!! ToDo: cleaner
553 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
554 rdrNameToCLabel rn suffix =
555 _UNPK_(moduleNameFS (rdrNameModule rn))
556 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
558 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
559 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
561 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
562 linkPrimAlt ie ce (AltPrim lit rhs)
563 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
565 linkDefault ie ce Nothing = Nothing
566 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
568 -- ---------------------------------------------------------------------------
569 -- The interpreter proper
570 -- ---------------------------------------------------------------------------
572 -- The dynamic environment contains everything boxed.
573 -- eval* functions which look up values in it will know the
574 -- representation of the thing they are looking up, so they
575 -- can cast/unbox it as necessary.
577 -- ---------------------------------------------------------------------------
578 -- Evaluator for things of boxed (pointer) representation
579 -- ---------------------------------------------------------------------------
581 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
585 -- | trace ("evalP: " ++ showExprTag expr) False
586 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
587 = error "evalP: ?!?!"
590 evalP (Native p) de = unsafeCoerce# p
592 -- First try the dynamic env. If that fails, assume it's a top-level
593 -- binding and look in the static env. That gives an Expr, which we
594 -- must convert to a boxed thingy by applying evalP to it. Because
595 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
596 -- CAFs), it's always safe to use evalP.
598 = case lookupUFM de v of
600 Nothing -> error ("evalP: lookupUFM " ++ show v)
602 -- Deal with application of a function returning a pointer rep
603 -- to arguments of any persuasion. Note that the function itself
604 -- always has pointer rep.
605 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
606 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
607 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
608 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
610 -- Lambdas always return P-rep, but we need to do different things
611 -- depending on both the argument and result representations.
613 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
615 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
617 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
619 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
621 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
623 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
625 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
627 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
629 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
631 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
633 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
635 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
637 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
639 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
641 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
643 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
646 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
647 -- except in the sense that we go on and evaluate the body with whichever
648 -- evaluator was used for the expression as a whole.
649 evalP (NonRecP bind e) de
650 = evalP e (augment_nonrec bind de)
651 evalP (RecP binds b) de
652 = evalP b (augment_rec binds de)
653 evalP (CaseAlgP bndr expr alts def) de
654 = case helper_caseAlg bndr expr alts def de of
655 (rhs, de') -> evalP rhs de'
656 evalP (CasePrimP bndr expr alts def) de
657 = case helper_casePrim bndr expr alts def de of
658 (rhs, de') -> evalP rhs de'
661 -- ConApp can only be handled by evalP
662 evalP (ConApp itbl args) se de
665 -- This appalling hack suggested (gleefully) by SDM
666 -- It is not well typed (needless to say?)
667 loop :: [Expr] -> boxed
669 = trace "loop-empty" (
670 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
673 = trace "loop-not-empty" (
675 RepI -> case evalI a de of i# -> loop as i#
676 RepP -> let p = evalP a de in loop as p
680 evalP (ConAppI (A# itbl) a1) de
681 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
683 evalP (ConApp (A# itbl)) de
684 = mci_make_constr itbl
686 evalP (ConAppP (A# itbl) a1) de
687 = let p1 = evalP a1 de
688 in mci_make_constrP itbl p1
690 evalP (ConAppPP (A# itbl) a1 a2) de
691 = let p1 = evalP a1 de
693 in mci_make_constrPP itbl p1 p2
695 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
696 = let p1 = evalP a1 de
699 in mci_make_constrPPP itbl p1 p2 p3
704 = error ("evalP: unhandled case: " ++ showExprTag other)
706 --------------------------------------------------------
707 --- Evaluator for things of Int# representation
708 --------------------------------------------------------
710 -- Evaluate something which has an unboxed Int rep
711 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
714 -- | trace ("evalI: " ++ showExprTag expr) False
715 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
716 = error "evalI: ?!?!"
718 evalI (LitI i#) de = i#
721 case lookupUFM de v of
722 Just e -> case unsafeCoerce# e of I# i -> i
723 Nothing -> error ("evalI: lookupUFM " ++ show v)
725 -- Deal with application of a function returning an Int# rep
726 -- to arguments of any persuasion. Note that the function itself
727 -- always has pointer rep.
728 evalI (AppII e1 e2) de
729 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
730 evalI (AppPI e1 e2) de
731 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
732 evalI (AppFI e1 e2) de
733 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
734 evalI (AppDI e1 e2) de
735 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
737 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
738 -- except in the sense that we go on and evaluate the body with whichever
739 -- evaluator was used for the expression as a whole.
740 evalI (NonRecI bind b) de
741 = evalI b (augment_nonrec bind de)
742 evalI (RecI binds b) de
743 = evalI b (augment_rec binds de)
744 evalI (CaseAlgI bndr expr alts def) de
745 = case helper_caseAlg bndr expr alts def de of
746 (rhs, de') -> evalI rhs de'
747 evalI (CasePrimI bndr expr alts def) de
748 = case helper_casePrim bndr expr alts def de of
749 (rhs, de') -> evalI rhs de'
751 -- evalI can't be applied to a lambda term, by defn, since those
754 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
755 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
757 --evalI (NonRec (IBind v e) b) de
758 -- = evalI b (augment de v (eval e de))
761 = error ("evalI: unhandled case: " ++ showExprTag other)
763 --------------------------------------------------------
764 --- Evaluator for things of Float# representation
765 --------------------------------------------------------
767 -- Evaluate something which has an unboxed Int rep
768 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
771 -- | trace ("evalF: " ++ showExprTag expr) False
772 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
773 = error "evalF: ?!?!"
775 evalF (LitF f#) de = f#
778 case lookupUFM de v of
779 Just e -> case unsafeCoerce# e of F# i -> i
780 Nothing -> error ("evalF: lookupUFM " ++ show v)
782 -- Deal with application of a function returning an Int# rep
783 -- to arguments of any persuasion. Note that the function itself
784 -- always has pointer rep.
785 evalF (AppIF e1 e2) de
786 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
787 evalF (AppPF e1 e2) de
788 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
789 evalF (AppFF e1 e2) de
790 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
791 evalF (AppDF e1 e2) de
792 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
794 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
795 -- except in the sense that we go on and evaluate the body with whichever
796 -- evaluator was used for the expression as a whole.
797 evalF (NonRecF bind b) de
798 = evalF b (augment_nonrec bind de)
799 evalF (RecF binds b) de
800 = evalF b (augment_rec binds de)
801 evalF (CaseAlgF bndr expr alts def) de
802 = case helper_caseAlg bndr expr alts def de of
803 (rhs, de') -> evalF rhs de'
804 evalF (CasePrimF bndr expr alts def) de
805 = case helper_casePrim bndr expr alts def de of
806 (rhs, de') -> evalF rhs de'
808 -- evalF can't be applied to a lambda term, by defn, since those
811 evalF (PrimOpF op _) de
812 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
815 = error ("evalF: unhandled case: " ++ showExprTag other)
817 --------------------------------------------------------
818 --- Evaluator for things of Double# representation
819 --------------------------------------------------------
821 -- Evaluate something which has an unboxed Int rep
822 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
825 -- | trace ("evalD: " ++ showExprTag expr) False
826 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
827 = error "evalD: ?!?!"
829 evalD (LitD d#) de = d#
832 case lookupUFM de v of
833 Just e -> case unsafeCoerce# e of D# i -> i
834 Nothing -> error ("evalD: lookupUFM " ++ show v)
836 -- Deal with application of a function returning an Int# rep
837 -- to arguments of any persuasion. Note that the function itself
838 -- always has pointer rep.
839 evalD (AppID e1 e2) de
840 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
841 evalD (AppPD e1 e2) de
842 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
843 evalD (AppFD e1 e2) de
844 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
845 evalD (AppDD e1 e2) de
846 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
848 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
849 -- except in the sense that we go on and evaluate the body with whichever
850 -- evaluator was used for the expression as a whole.
851 evalD (NonRecD bind b) de
852 = evalD b (augment_nonrec bind de)
853 evalD (RecD binds b) de
854 = evalD b (augment_rec binds de)
855 evalD (CaseAlgD bndr expr alts def) de
856 = case helper_caseAlg bndr expr alts def de of
857 (rhs, de') -> evalD rhs de'
858 evalD (CasePrimD bndr expr alts def) de
859 = case helper_casePrim bndr expr alts def de of
860 (rhs, de') -> evalD rhs de'
862 -- evalD can't be applied to a lambda term, by defn, since those
865 evalD (PrimOpD op _) de
866 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
869 = error ("evalD: unhandled case: " ++ showExprTag other)
871 --------------------------------------------------------
872 --- Helper bits and pieces
873 --------------------------------------------------------
875 -- Find the Rep of any Expr
876 repOf :: LinkedIExpr -> Rep
878 repOf (LamPP _ _) = RepP
879 repOf (LamPI _ _) = RepP
880 repOf (LamPF _ _) = RepP
881 repOf (LamPD _ _) = RepP
882 repOf (LamIP _ _) = RepP
883 repOf (LamII _ _) = RepP
884 repOf (LamIF _ _) = RepP
885 repOf (LamID _ _) = RepP
886 repOf (LamFP _ _) = RepP
887 repOf (LamFI _ _) = RepP
888 repOf (LamFF _ _) = RepP
889 repOf (LamFD _ _) = RepP
890 repOf (LamDP _ _) = RepP
891 repOf (LamDI _ _) = RepP
892 repOf (LamDF _ _) = RepP
893 repOf (LamDD _ _) = RepP
895 repOf (AppPP _ _) = RepP
896 repOf (AppPI _ _) = RepI
897 repOf (AppPF _ _) = RepF
898 repOf (AppPD _ _) = RepD
899 repOf (AppIP _ _) = RepP
900 repOf (AppII _ _) = RepI
901 repOf (AppIF _ _) = RepF
902 repOf (AppID _ _) = RepD
903 repOf (AppFP _ _) = RepP
904 repOf (AppFI _ _) = RepI
905 repOf (AppFF _ _) = RepF
906 repOf (AppFD _ _) = RepD
907 repOf (AppDP _ _) = RepP
908 repOf (AppDI _ _) = RepI
909 repOf (AppDF _ _) = RepF
910 repOf (AppDD _ _) = RepD
912 repOf (NonRecP _ _) = RepP
913 repOf (NonRecI _ _) = RepI
914 repOf (NonRecF _ _) = RepF
915 repOf (NonRecD _ _) = RepD
917 repOf (LitI _) = RepI
918 repOf (LitF _) = RepF
919 repOf (LitD _) = RepD
921 repOf (VarP _) = RepI
922 repOf (VarI _) = RepI
923 repOf (VarF _) = RepF
924 repOf (VarD _) = RepD
926 repOf (PrimOpP _ _) = RepP
927 repOf (PrimOpI _ _) = RepI
928 repOf (PrimOpF _ _) = RepF
929 repOf (PrimOpD _ _) = RepD
931 repOf (ConApp _) = RepP
932 repOf (ConAppI _ _) = RepP
933 repOf (ConAppP _ _) = RepP
934 repOf (ConAppPP _ _ _) = RepP
935 repOf (ConAppPPP _ _ _ _) = RepP
937 repOf (CaseAlgP _ _ _ _) = RepP
938 repOf (CaseAlgI _ _ _ _) = RepI
939 repOf (CaseAlgF _ _ _ _) = RepF
940 repOf (CaseAlgD _ _ _ _) = RepD
942 repOf (CasePrimP _ _ _ _) = RepP
943 repOf (CasePrimI _ _ _ _) = RepI
944 repOf (CasePrimF _ _ _ _) = RepF
945 repOf (CasePrimD _ _ _ _) = RepD
948 = error ("repOf: unhandled case: " ++ showExprTag other)
950 -- how big (in words) is one of these
951 repSizeW :: Rep -> Int
956 -- Evaluate an expression, using the appropriate evaluator,
957 -- then box up the result. Note that it's only safe to use this
958 -- to create values to put in the environment. You can't use it
959 -- to create a value which might get passed to native code since that
960 -- code will have no idea that unboxed things have been boxed.
961 eval :: LinkedIExpr -> UniqFM boxed -> boxed
964 RepI -> unsafeCoerce# (I# (evalI expr de))
965 RepP -> evalP expr de
966 RepF -> unsafeCoerce# (F# (evalF expr de))
967 RepD -> unsafeCoerce# (D# (evalD expr de))
969 -- Evaluate the scrutinee of a case, select an alternative,
970 -- augment the environment appropriately, and return the alt
971 -- and the augmented environment.
972 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
974 -> (LinkedIExpr, UniqFM boxed)
975 helper_caseAlg bndr expr alts def de
976 = let exprEv = evalP expr de
978 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
979 case select_altAlg (tagOf exprEv) alts def of
980 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
983 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
985 -> (LinkedIExpr, UniqFM boxed)
986 helper_casePrim bndr expr alts def de
988 -- Umm, can expr have any other rep? Yes ...
989 -- CharRep, DoubleRep, FloatRep. What about string reps?
990 RepI -> case evalI expr de of
991 i# -> (select_altPrim alts def (LitI i#),
992 addToUFM de bndr (unsafeCoerce# (I# i#)))
995 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
996 augment_from_constr de con ([],offset)
998 augment_from_constr de con ((v,rep):vs,offset)
1001 RepP -> indexPtrOffClosure con offset
1002 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1004 augment_from_constr (addToUFM de v v_binding) con
1005 (vs,offset + repSizeW rep)
1007 -- Augment the environment for a non-recursive let.
1008 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1009 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1011 -- Augment the environment for a recursive let.
1012 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1013 augment_rec binds de
1014 = let vars = map binder binds
1015 rhss = map bindee binds
1016 rhs_vs = map (\rhs -> eval rhs de') rhss
1017 de' = addListToUFM de (zip vars rhs_vs)
1021 -- a must be a constructor?
1023 tagOf x = I# (dataToTag# x)
1025 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1026 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1027 select_altAlg tag [] (Just def) = ([],def)
1028 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1031 else select_altAlg tag alts def
1033 -- literal may only be a literal, not an arbitrary expression
1034 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1035 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1036 select_altPrim [] (Just def) literal = def
1037 select_altPrim ((AltPrim lit rhs):alts) def literal
1038 = if eqLits lit literal
1040 else select_altPrim alts def literal
1042 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1045 -- a is a constructor
1046 indexPtrOffClosure :: a -> Int -> b
1047 indexPtrOffClosure con (I# offset)
1048 = case indexPtrOffClosure# con offset of (# x #) -> x
1050 indexIntOffClosure :: a -> Int -> Int#
1051 indexIntOffClosure con (I# offset)
1052 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1055 ------------------------------------------------------------------------
1056 --- Manufacturing of info tables for DataCons defined in this module ---
1057 ------------------------------------------------------------------------
1060 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1062 -- Assumes constructors are numbered from zero, not one
1063 make_constr_itbls :: [DataCon] -> IO ItblEnv
1064 make_constr_itbls cons
1066 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1067 return (listToFM is)
1069 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1070 return (listToFM is)
1072 mk_vecret_itbl (dcon, conNo)
1073 = mk_itbl dcon conNo (vecret_entry conNo)
1074 mk_dirret_itbl (dcon, conNo)
1075 = mk_itbl dcon conNo mci_constr_entry
1077 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1078 mk_itbl dcon conNo entry_addr
1079 = let (tot_wds, ptr_wds, _)
1080 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1082 nptrs = tot_wds - ptr_wds
1083 itbl = StgInfoTable {
1084 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1085 tipe = fromIntegral cONSTR,
1086 srtlen = fromIntegral conNo,
1087 code0 = fromIntegral code0, code1 = fromIntegral code1,
1088 code2 = fromIntegral code2, code3 = fromIntegral code3,
1089 code4 = fromIntegral code4, code5 = fromIntegral code5,
1090 code6 = fromIntegral code6, code7 = fromIntegral code7
1092 -- Make a piece of code to jump to "entry_label".
1093 -- This is the only arch-dependent bit.
1094 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1095 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1097 -- B8 ZZ YY XX WW FF E0
1098 (code0,code1,code2,code3,code4,code5,code6,code7)
1099 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1100 byte 2 entry_addr_w, byte 3 entry_addr_w,
1104 entry_addr_w :: Word32
1105 entry_addr_w = fromIntegral (addrToInt entry_addr)
1107 do addr <- mallocElem itbl
1108 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1109 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1110 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1112 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1115 byte :: Int -> Word32 -> Word32
1116 byte 0 w = w .&. 0xFF
1117 byte 1 w = (w `shiftR` 8) .&. 0xFF
1118 byte 2 w = (w `shiftR` 16) .&. 0xFF
1119 byte 3 w = (w `shiftR` 24) .&. 0xFF
1122 vecret_entry 0 = mci_constr1_entry
1123 vecret_entry 1 = mci_constr2_entry
1124 vecret_entry 2 = mci_constr3_entry
1125 vecret_entry 3 = mci_constr4_entry
1126 vecret_entry 4 = mci_constr5_entry
1127 vecret_entry 5 = mci_constr6_entry
1128 vecret_entry 6 = mci_constr7_entry
1129 vecret_entry 7 = mci_constr8_entry
1131 -- entry point for direct returns for created constr itbls
1132 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1133 -- and the 8 vectored ones
1134 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1135 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1136 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1137 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1138 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1139 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1140 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1141 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1145 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1148 -- Ultra-minimalist version specially for constructors
1149 data StgInfoTable = StgInfoTable {
1154 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1158 instance Storable StgInfoTable where
1161 = (sum . map (\f -> f itbl))
1162 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1163 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1164 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1167 = (sum . map (\f -> f itbl))
1168 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1169 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1170 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1173 = do a1 <- store (ptrs itbl) a0
1174 a2 <- store (nptrs itbl) a1
1175 a3 <- store (tipe itbl) a2
1176 a4 <- store (srtlen itbl) a3
1177 a5 <- store (code0 itbl) a4
1178 a6 <- store (code1 itbl) a5
1179 a7 <- store (code2 itbl) a6
1180 a8 <- store (code3 itbl) a7
1181 a9 <- store (code4 itbl) a8
1182 aA <- store (code5 itbl) a9
1183 aB <- store (code6 itbl) aA
1184 aC <- store (code7 itbl) aB
1188 = do (a1,ptrs) <- load a0
1189 (a2,nptrs) <- load a1
1190 (a3,tipe) <- load a2
1191 (a4,srtlen) <- load a3
1192 (a5,code0) <- load a4
1193 (a6,code1) <- load a5
1194 (a7,code2) <- load a6
1195 (a8,code3) <- load a7
1196 (a9,code4) <- load a8
1197 (aA,code5) <- load a9
1198 (aB,code6) <- load aA
1199 (aC,code7) <- load aB
1200 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1201 srtlen = srtlen, tipe = tipe,
1202 code0 = code0, code1 = code1, code2 = code2,
1203 code3 = code3, code4 = code4, code5 = code5,
1204 code6 = code6, code7 = code7 }
1206 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1207 fieldSz sel x = sizeOf (sel x)
1209 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1210 fieldAl sel x = alignment (sel x)
1212 store :: Storable a => a -> Addr -> IO Addr
1213 store x addr = do poke addr x
1214 return (addr `plusAddr` fromIntegral (sizeOf x))
1216 load :: Storable a => Addr -> IO (Addr, a)
1217 load addr = do x <- peek addr
1218 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1220 -----------------------------------------------------------------------------q
1222 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1224 #endif /* ndef GHCI */