2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
14 {- -----------------------------------------------------------------------------
17 - link should be in the IO monad, so it can modify the symtabs as it
20 - need a way to remove the bindings for a module from the symtabs.
21 maybe the symtabs should be indexed by module first.
23 - change the representation to something less verbose (?).
25 - converting string literals to Addr# is horrible and introduces
26 a memory leak. See if something can be done about this.
28 ----------------------------------------------------------------------------- -}
30 #include "HsVersions.h"
32 #if __GLASGOW_HASKELL__ <= 408
34 import Panic ( panic )
35 import RdrName ( RdrName )
36 import PrelAddr ( Addr )
37 import FiniteMap ( FiniteMap )
38 import InterpSyn ( HValue )
40 type ItblEnv = FiniteMap RdrName Addr
41 type ClosureEnv = FiniteMap RdrName HValue
42 linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
43 stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
48 import Id ( Id, idPrimRep )
51 import PrimOp ( PrimOp(..) )
52 import PrimRep ( PrimRep(..) )
53 import Literal ( Literal(..) )
54 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
55 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
56 import ClosureInfo ( mkVirtHeapOffsets )
57 import Name ( toRdrName )
61 import {-# SOURCE #-} MCI_make_constr
63 import IOExts ( unsafePerformIO ) -- ToDo: remove
64 import PrelGHC --( unsafeCoerce#, dataToTag#,
65 -- indexPtrOffClosure#, indexWordOffClosure# )
66 import PrelAddr ( Addr(..) )
67 import PrelFloat ( Float(..), Double(..) )
73 import GlaExts ( Int(..) )
74 import Module ( moduleNameFS )
76 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
77 import Class ( Class, classTyCon )
81 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
83 import Panic ( panic )
84 import OccName ( occNameString )
87 -- ---------------------------------------------------------------------------
88 -- Environments needed by the linker
89 -- ---------------------------------------------------------------------------
91 type ItblEnv = FiniteMap RdrName Addr
92 type ClosureEnv = FiniteMap RdrName HValue
94 -- ---------------------------------------------------------------------------
95 -- Run our STG program through the interpreter
96 -- ---------------------------------------------------------------------------
99 -- To be nuked at some point soon.
100 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
102 -- the bindings need to have a binding for stgMain, and the
103 -- body of it had better represent something of type Int# -> Int#
104 runStgI tycons classes stgbinds
106 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
110 = "-------------------- Unlinked Binds --------------------\n"
111 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
114 hPutStr stderr dbg_txt
116 (linked_binds, ie, ce) <-
117 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
120 = "-------------------- Linked Binds --------------------\n"
121 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
124 hPutStr stderr dbg_txt
127 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
129 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
132 = I# (evalI (AppII stgMain (LitI 0#))
133 emptyUFM{-initial de-}
138 -- ---------------------------------------------------------------------------
139 -- Convert STG to an unlinked interpretable
140 -- ---------------------------------------------------------------------------
142 -- visible from outside
143 stgToInterpSyn :: [StgBinding]
144 -> [TyCon] -> [Class]
145 -> IO ([UnlinkedIBind], ItblEnv)
146 stgToInterpSyn binds local_tycons local_classes
147 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
148 let tycs = local_tycons ++ map classTyCon local_classes
149 itblenv <- mkITbls tycs
150 return (ibinds, itblenv)
153 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
154 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
155 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
156 where ie' = addListToUniqSet ie (map fst vs_n_es)
158 isRec (StgNonRec _ _) = False
159 isRec (StgRec _) = True
161 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
162 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
165 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
166 rhsRep = repOfStgExpr rhs
167 mkLambdas [] = rhsExpr
168 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
169 rhs2expr ie (StgRhsCon ccs dcon args)
170 = conapp2expr ie dcon args
172 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
173 conapp2expr ie dcon args
174 = mkConApp con_rdrname reps exprs
176 con_rdrname = toRdrName dcon
177 exprs = map (arg2expr ie) inHeapOrder
178 reps = map repOfArg inHeapOrder
179 inHeapOrder = toHeapOrder args
181 toHeapOrder :: [StgArg] -> [StgArg]
183 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
184 (rearranged, offsets) = unzip rearranged_w_offsets
188 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
190 -- Handle most common cases specially; do the rest with a generic
191 -- mechanism (deferred till later :)
192 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
193 mkConApp nm [] [] = ConApp nm
194 mkConApp nm [RepI] [a1] = ConAppI nm a1
195 mkConApp nm [RepP] [a1] = ConAppP nm a1
196 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
197 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
198 mkConApp nm reps args
199 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
201 mkLam RepP RepP = LamPP
202 mkLam RepI RepP = LamIP
203 mkLam RepP RepI = LamPI
204 mkLam RepI RepI = LamII
205 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
207 mkApp RepP RepP = AppPP
208 mkApp RepI RepP = AppIP
209 mkApp RepP RepI = AppPI
210 mkApp RepI RepI = AppII
211 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
214 repOfId = primRep2Rep . idPrimRep
219 -- genuine lifted types
222 -- all these are unboxed, fit into a word, and we assume they
223 -- all have the same call/return convention.
231 -- these are pretty dodgy: really pointers, but
232 -- we can't let the compiler build thunks with these reps.
233 ForeignObjRep -> RepP
234 StableNameRep -> RepP
239 other -> pprPanic "primRep2Rep" (ppr other)
241 repOfStgExpr :: StgExpr -> Rep
246 StgCase scrut live liveR bndr srt alts
247 -> case altRhss alts of
248 (a:_) -> repOfStgExpr a
249 [] -> panic "repOfStgExpr: no alts"
253 -> repOfApp ((deNoteType.repType.idType) var) (length args)
255 StgPrimApp op args res_ty
256 -> (primRep2Rep.typePrimRep) res_ty
258 StgLet binds body -> repOfStgExpr body
259 StgLetNoEscape live liveR binds body -> repOfStgExpr body
261 StgConApp con args -> RepP -- by definition
264 -> pprPanic "repOfStgExpr" (ppr other)
266 altRhss (StgAlgAlts ty alts def)
267 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
268 altRhss (StgPrimAlts ty alts def)
269 = [rhs | (lit,rhs) <- alts] ++ defRhs def
272 defRhs (StgBindDefault rhs)
275 -- returns the Rep of the result of applying ty to n args.
276 repOfApp :: Type -> Int -> Rep
277 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
278 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
290 MachStr _ -> RepI -- because it's a ptr outside the heap
291 other -> pprPanic "repOfLit" (ppr lit)
293 lit2expr :: Literal -> UnlinkedIExpr
296 MachInt i -> case fromIntegral i of I# i -> LitI i
297 MachWord i -> case fromIntegral i of I# i -> LitI i
298 MachAddr i -> case fromIntegral i of I# i -> LitI i
299 MachChar i -> case fromIntegral i of I# i -> LitI i
300 MachFloat f -> case fromRational f of F# f -> LitF f
301 MachDouble f -> case fromRational f of D# f -> LitD f
304 CharStr s i -> LitI (addr2Int# s)
307 -- sigh, a string in the heap is no good to us. We need a
308 -- static C pointer, since the type of a string literal is
309 -- Addr#. So, copy the string into C land and introduce a
310 -- memory leak at the same time.
312 case unsafePerformIO (do a <- malloc (n+1);
313 strncpy a ba (fromIntegral n);
314 writeCharOffAddr a n '\0'
316 of A# a -> LitI (addr2Int# a)
318 _ -> error "StgInterp.lit2expr: unhandled string constant type"
320 other -> pprPanic "lit2expr" (ppr lit)
322 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
326 -> mkVar ie (repOfId var) var
329 -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
333 StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
334 | repOfStgExpr scrut /= RepP
335 -> mkCasePrim (repOfStgExpr stgexpr)
336 bndr (stg2expr ie scrut)
340 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
341 | repOfStgExpr scrut == RepP
342 -> mkCaseAlg (repOfStgExpr stgexpr)
343 bndr (stg2expr ie scrut)
347 StgPrimApp op args res_ty
348 -> mkPrimOp (repOfStgExpr stgexpr)
349 op (map (arg2expr ie) args)
352 -> conapp2expr ie dcon args
354 StgLet binds@(StgNonRec v e) body
355 -> mkNonRec (repOfStgExpr stgexpr)
356 (head (translateBind ie binds))
357 (stg2expr (addOneToUniqSet ie v) body)
359 StgLet binds@(StgRec bs) body
360 -> mkRec (repOfStgExpr stgexpr)
361 (translateBind ie binds)
362 (stg2expr (addListToUniqSet ie (map fst bs)) body)
365 -> pprPanic "stg2expr" (ppr stgexpr)
368 = AltPrim (lit2expr lit) (stg2expr ie rhs)
369 doAlgAlt (dcon,vars,uses,rhs)
370 = AltAlg (dataConTag dcon - 1)
371 (map id2VaaRep (toHeapOrder vars))
372 (stg2expr (addListToUniqSet ie vars) rhs)
375 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
376 (rearranged,offsets) = unzip rearranged_w_offsets
380 def2expr StgNoDefault = Nothing
381 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
383 mkAppChain ie result_rep so_far []
385 mkAppChain ie result_rep so_far [a]
386 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
387 mkAppChain ie result_rep so_far (a:as)
388 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
390 mkCasePrim RepI = CasePrimI
391 mkCasePrim RepP = CasePrimP
393 mkCaseAlg RepI = CaseAlgI
394 mkCaseAlg RepP = CaseAlgP
396 -- any var that isn't in scope is turned into a Native
398 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
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 :: ClosureEnv -- incoming global closure env; returned updated
427 -> ItblEnv -- incoming global itbl env; returned updated
428 -> [([UnlinkedIBind], ItblEnv)]
429 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
430 linkIModules gce gie 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 -- JRS 001025: above comment is probably out of date ... interpret
454 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
455 linkIBinds ie ce binds = map (linkIBind ie ce) binds
457 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
459 linkIExpr ie ce expr = case expr of
461 CaseAlgP bndr expr alts dflt ->
462 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
463 (linkDefault ie ce dflt)
465 CaseAlgI bndr expr alts dflt ->
466 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
467 (linkDefault ie ce dflt)
469 CasePrimP bndr expr alts dflt ->
470 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
471 (linkDefault ie ce dflt)
473 CasePrimI bndr expr alts dflt ->
474 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
475 (linkDefault ie ce dflt)
478 ConApp (lookupCon ie con)
481 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
484 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
486 ConAppPP con arg0 arg1 ->
487 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
489 ConAppPPP con arg0 arg1 arg2 ->
490 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
491 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
493 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
494 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
496 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
497 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
499 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
500 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
506 Native var -> lookupNative ce var
508 VarP v -> lookupVar ce VarP v
509 VarI v -> lookupVar ce VarI v
511 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
512 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
513 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
514 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
516 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
517 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
518 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
519 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
522 case lookupFM ie con of
525 -- try looking up in the object files.
527 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
529 Nothing -> pprPanic "linkIExpr" (ppr con)
531 lookupNative ce var =
532 case lookupFM ce var of
535 -- try looking up in the object files.
536 let lbl = (rdrNameToCLabel var "closure")
537 addr = unsafePerformIO (lookupSymbol lbl) in
538 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
539 Just (A# addr) -> Native (unsafeCoerce# addr)
540 Nothing -> pprPanic "linkIExpr" (ppr var)
542 -- some VarI/VarP refer to top-level interpreted functions; we change
543 -- them into Natives here.
545 case lookupFM ce (toRdrName v) of
549 -- HACK!!! ToDo: cleaner
550 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
551 rdrNameToCLabel rn suffix =
552 _UNPK_(moduleNameFS (rdrNameModule rn))
553 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
555 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
556 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
558 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
559 linkPrimAlt ie ce (AltPrim lit rhs)
560 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
562 linkDefault ie ce Nothing = Nothing
563 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
565 -- ---------------------------------------------------------------------------
566 -- The interpreter proper
567 -- ---------------------------------------------------------------------------
569 -- The dynamic environment contains everything boxed.
570 -- eval* functions which look up values in it will know the
571 -- representation of the thing they are looking up, so they
572 -- can cast/unbox it as necessary.
574 -- ---------------------------------------------------------------------------
575 -- Evaluator for things of boxed (pointer) representation
576 -- ---------------------------------------------------------------------------
578 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
582 -- | trace ("evalP: " ++ showExprTag expr) False
583 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
584 = error "evalP: ?!?!"
587 evalP (Native p) de = unsafeCoerce# p
589 -- First try the dynamic env. If that fails, assume it's a top-level
590 -- binding and look in the static env. That gives an Expr, which we
591 -- must convert to a boxed thingy by applying evalP to it. Because
592 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
593 -- CAFs), it's always safe to use evalP.
595 = case lookupUFM de v of
597 Nothing -> error ("evalP: lookupUFM " ++ show v)
599 -- Deal with application of a function returning a pointer rep
600 -- to arguments of any persuasion. Note that the function itself
601 -- always has pointer rep.
602 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
603 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
604 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
605 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
607 -- Lambdas always return P-rep, but we need to do different things
608 -- depending on both the argument and result representations.
610 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
612 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
614 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
616 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
618 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
620 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
622 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
624 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
626 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
628 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
630 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
632 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
634 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
636 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
638 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
640 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
643 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
644 -- except in the sense that we go on and evaluate the body with whichever
645 -- evaluator was used for the expression as a whole.
646 evalP (NonRecP bind e) de
647 = evalP e (augment_nonrec bind de)
648 evalP (RecP binds b) de
649 = evalP b (augment_rec binds de)
650 evalP (CaseAlgP bndr expr alts def) de
651 = case helper_caseAlg bndr expr alts def de of
652 (rhs, de') -> evalP rhs de'
653 evalP (CasePrimP bndr expr alts def) de
654 = case helper_casePrim bndr expr alts def de of
655 (rhs, de') -> evalP rhs de'
658 -- ConApp can only be handled by evalP
659 evalP (ConApp itbl args) se de
662 -- This appalling hack suggested (gleefully) by SDM
663 -- It is not well typed (needless to say?)
664 loop :: [Expr] -> boxed
666 = trace "loop-empty" (
667 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
670 = trace "loop-not-empty" (
672 RepI -> case evalI a de of i# -> loop as i#
673 RepP -> let p = evalP a de in loop as p
677 evalP (ConAppI (A# itbl) a1) de
678 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
680 evalP (ConApp (A# itbl)) de
681 = mci_make_constr itbl
683 evalP (ConAppP (A# itbl) a1) de
684 = let p1 = evalP a1 de
685 in mci_make_constrP itbl p1
687 evalP (ConAppPP (A# itbl) a1 a2) de
688 = let p1 = evalP a1 de
690 in mci_make_constrPP itbl p1 p2
692 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
693 = let p1 = evalP a1 de
696 in mci_make_constrPPP itbl p1 p2 p3
701 = error ("evalP: unhandled case: " ++ showExprTag other)
703 --------------------------------------------------------
704 --- Evaluator for things of Int# representation
705 --------------------------------------------------------
707 -- Evaluate something which has an unboxed Int rep
708 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
711 -- | trace ("evalI: " ++ showExprTag expr) False
712 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
713 = error "evalI: ?!?!"
715 evalI (LitI i#) de = i#
718 case lookupUFM de v of
719 Just e -> case unsafeCoerce# e of I# i -> i
720 Nothing -> error ("evalI: lookupUFM " ++ show v)
722 -- Deal with application of a function returning an Int# rep
723 -- to arguments of any persuasion. Note that the function itself
724 -- always has pointer rep.
725 evalI (AppII e1 e2) de
726 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
727 evalI (AppPI e1 e2) de
728 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
729 evalI (AppFI e1 e2) de
730 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
731 evalI (AppDI e1 e2) de
732 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
734 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
735 -- except in the sense that we go on and evaluate the body with whichever
736 -- evaluator was used for the expression as a whole.
737 evalI (NonRecI bind b) de
738 = evalI b (augment_nonrec bind de)
739 evalI (RecI binds b) de
740 = evalI b (augment_rec binds de)
741 evalI (CaseAlgI bndr expr alts def) de
742 = case helper_caseAlg bndr expr alts def de of
743 (rhs, de') -> evalI rhs de'
744 evalI (CasePrimI bndr expr alts def) de
745 = case helper_casePrim bndr expr alts def de of
746 (rhs, de') -> evalI rhs de'
748 -- evalI can't be applied to a lambda term, by defn, since those
751 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
752 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
754 --evalI (NonRec (IBind v e) b) de
755 -- = evalI b (augment de v (eval e de))
758 = error ("evalI: unhandled case: " ++ showExprTag other)
760 --------------------------------------------------------
761 --- Evaluator for things of Float# representation
762 --------------------------------------------------------
764 -- Evaluate something which has an unboxed Int rep
765 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
768 -- | trace ("evalF: " ++ showExprTag expr) False
769 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
770 = error "evalF: ?!?!"
772 evalF (LitF f#) de = f#
775 case lookupUFM de v of
776 Just e -> case unsafeCoerce# e of F# i -> i
777 Nothing -> error ("evalF: lookupUFM " ++ show v)
779 -- Deal with application of a function returning an Int# rep
780 -- to arguments of any persuasion. Note that the function itself
781 -- always has pointer rep.
782 evalF (AppIF e1 e2) de
783 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
784 evalF (AppPF e1 e2) de
785 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
786 evalF (AppFF e1 e2) de
787 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
788 evalF (AppDF e1 e2) de
789 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
791 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
792 -- except in the sense that we go on and evaluate the body with whichever
793 -- evaluator was used for the expression as a whole.
794 evalF (NonRecF bind b) de
795 = evalF b (augment_nonrec bind de)
796 evalF (RecF binds b) de
797 = evalF b (augment_rec binds de)
798 evalF (CaseAlgF bndr expr alts def) de
799 = case helper_caseAlg bndr expr alts def de of
800 (rhs, de') -> evalF rhs de'
801 evalF (CasePrimF bndr expr alts def) de
802 = case helper_casePrim bndr expr alts def de of
803 (rhs, de') -> evalF rhs de'
805 -- evalF can't be applied to a lambda term, by defn, since those
808 evalF (PrimOpF op _) de
809 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
812 = error ("evalF: unhandled case: " ++ showExprTag other)
814 --------------------------------------------------------
815 --- Evaluator for things of Double# representation
816 --------------------------------------------------------
818 -- Evaluate something which has an unboxed Int rep
819 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
822 -- | trace ("evalD: " ++ showExprTag expr) False
823 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
824 = error "evalD: ?!?!"
826 evalD (LitD d#) de = d#
829 case lookupUFM de v of
830 Just e -> case unsafeCoerce# e of D# i -> i
831 Nothing -> error ("evalD: lookupUFM " ++ show v)
833 -- Deal with application of a function returning an Int# rep
834 -- to arguments of any persuasion. Note that the function itself
835 -- always has pointer rep.
836 evalD (AppID e1 e2) de
837 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
838 evalD (AppPD e1 e2) de
839 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
840 evalD (AppFD e1 e2) de
841 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
842 evalD (AppDD e1 e2) de
843 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
845 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
846 -- except in the sense that we go on and evaluate the body with whichever
847 -- evaluator was used for the expression as a whole.
848 evalD (NonRecD bind b) de
849 = evalD b (augment_nonrec bind de)
850 evalD (RecD binds b) de
851 = evalD b (augment_rec binds de)
852 evalD (CaseAlgD bndr expr alts def) de
853 = case helper_caseAlg bndr expr alts def de of
854 (rhs, de') -> evalD rhs de'
855 evalD (CasePrimD bndr expr alts def) de
856 = case helper_casePrim bndr expr alts def de of
857 (rhs, de') -> evalD rhs de'
859 -- evalD can't be applied to a lambda term, by defn, since those
862 evalD (PrimOpD op _) de
863 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
866 = error ("evalD: unhandled case: " ++ showExprTag other)
868 --------------------------------------------------------
869 --- Helper bits and pieces
870 --------------------------------------------------------
872 -- Find the Rep of any Expr
873 repOf :: LinkedIExpr -> Rep
875 repOf (LamPP _ _) = RepP
876 repOf (LamPI _ _) = RepP
877 repOf (LamPF _ _) = RepP
878 repOf (LamPD _ _) = RepP
879 repOf (LamIP _ _) = RepP
880 repOf (LamII _ _) = RepP
881 repOf (LamIF _ _) = RepP
882 repOf (LamID _ _) = RepP
883 repOf (LamFP _ _) = RepP
884 repOf (LamFI _ _) = RepP
885 repOf (LamFF _ _) = RepP
886 repOf (LamFD _ _) = RepP
887 repOf (LamDP _ _) = RepP
888 repOf (LamDI _ _) = RepP
889 repOf (LamDF _ _) = RepP
890 repOf (LamDD _ _) = RepP
892 repOf (AppPP _ _) = RepP
893 repOf (AppPI _ _) = RepI
894 repOf (AppPF _ _) = RepF
895 repOf (AppPD _ _) = RepD
896 repOf (AppIP _ _) = RepP
897 repOf (AppII _ _) = RepI
898 repOf (AppIF _ _) = RepF
899 repOf (AppID _ _) = RepD
900 repOf (AppFP _ _) = RepP
901 repOf (AppFI _ _) = RepI
902 repOf (AppFF _ _) = RepF
903 repOf (AppFD _ _) = RepD
904 repOf (AppDP _ _) = RepP
905 repOf (AppDI _ _) = RepI
906 repOf (AppDF _ _) = RepF
907 repOf (AppDD _ _) = RepD
909 repOf (NonRecP _ _) = RepP
910 repOf (NonRecI _ _) = RepI
911 repOf (NonRecF _ _) = RepF
912 repOf (NonRecD _ _) = RepD
914 repOf (LitI _) = RepI
915 repOf (LitF _) = RepF
916 repOf (LitD _) = RepD
918 repOf (VarP _) = RepI
919 repOf (VarI _) = RepI
920 repOf (VarF _) = RepF
921 repOf (VarD _) = RepD
923 repOf (PrimOpP _ _) = RepP
924 repOf (PrimOpI _ _) = RepI
925 repOf (PrimOpF _ _) = RepF
926 repOf (PrimOpD _ _) = RepD
928 repOf (ConApp _) = RepP
929 repOf (ConAppI _ _) = RepP
930 repOf (ConAppP _ _) = RepP
931 repOf (ConAppPP _ _ _) = RepP
932 repOf (ConAppPPP _ _ _ _) = RepP
934 repOf (CaseAlgP _ _ _ _) = RepP
935 repOf (CaseAlgI _ _ _ _) = RepI
936 repOf (CaseAlgF _ _ _ _) = RepF
937 repOf (CaseAlgD _ _ _ _) = RepD
939 repOf (CasePrimP _ _ _ _) = RepP
940 repOf (CasePrimI _ _ _ _) = RepI
941 repOf (CasePrimF _ _ _ _) = RepF
942 repOf (CasePrimD _ _ _ _) = RepD
945 = error ("repOf: unhandled case: " ++ showExprTag other)
947 -- how big (in words) is one of these
948 repSizeW :: Rep -> Int
953 -- Evaluate an expression, using the appropriate evaluator,
954 -- then box up the result. Note that it's only safe to use this
955 -- to create values to put in the environment. You can't use it
956 -- to create a value which might get passed to native code since that
957 -- code will have no idea that unboxed things have been boxed.
958 eval :: LinkedIExpr -> UniqFM boxed -> boxed
961 RepI -> unsafeCoerce# (I# (evalI expr de))
962 RepP -> evalP expr de
963 RepF -> unsafeCoerce# (F# (evalF expr de))
964 RepD -> unsafeCoerce# (D# (evalD expr de))
966 -- Evaluate the scrutinee of a case, select an alternative,
967 -- augment the environment appropriately, and return the alt
968 -- and the augmented environment.
969 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
971 -> (LinkedIExpr, UniqFM boxed)
972 helper_caseAlg bndr expr alts def de
973 = let exprEv = evalP expr de
975 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
976 case select_altAlg (tagOf exprEv) alts def of
977 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
980 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
982 -> (LinkedIExpr, UniqFM boxed)
983 helper_casePrim bndr expr alts def de
985 -- Umm, can expr have any other rep? Yes ...
986 -- CharRep, DoubleRep, FloatRep. What about string reps?
987 RepI -> case evalI expr de of
988 i# -> (select_altPrim alts def (LitI i#),
989 addToUFM de bndr (unsafeCoerce# (I# i#)))
992 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
993 augment_from_constr de con ([],offset)
995 augment_from_constr de con ((v,rep):vs,offset)
998 RepP -> indexPtrOffClosure con offset
999 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1001 augment_from_constr (addToUFM de v v_binding) con
1002 (vs,offset + repSizeW rep)
1004 -- Augment the environment for a non-recursive let.
1005 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1006 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1008 -- Augment the environment for a recursive let.
1009 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1010 augment_rec binds de
1011 = let vars = map binder binds
1012 rhss = map bindee binds
1013 rhs_vs = map (\rhs -> eval rhs de') rhss
1014 de' = addListToUFM de (zip vars rhs_vs)
1018 -- a must be a constructor?
1020 tagOf x = I# (dataToTag# x)
1022 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1023 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1024 select_altAlg tag [] (Just def) = ([],def)
1025 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1028 else select_altAlg tag alts def
1030 -- literal may only be a literal, not an arbitrary expression
1031 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1032 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1033 select_altPrim [] (Just def) literal = def
1034 select_altPrim ((AltPrim lit rhs):alts) def literal
1035 = if eqLits lit literal
1037 else select_altPrim alts def literal
1039 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1042 -- a is a constructor
1043 indexPtrOffClosure :: a -> Int -> b
1044 indexPtrOffClosure con (I# offset)
1045 = case indexPtrOffClosure# con offset of (# x #) -> x
1047 indexIntOffClosure :: a -> Int -> Int#
1048 indexIntOffClosure con (I# offset)
1049 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1052 ------------------------------------------------------------------------
1053 --- Manufacturing of info tables for DataCons defined in this module ---
1054 ------------------------------------------------------------------------
1056 -- Make info tables for the data decls in this module
1057 mkITbls :: [TyCon] -> IO ItblEnv
1058 mkITbls [] = return emptyFM
1059 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1060 itbls2 <- mkITbls tcs
1061 return (itbls `plusFM` itbls2)
1063 mkITbl :: TyCon -> IO ItblEnv
1065 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1067 | not (isDataTyCon tc)
1069 | n == length dcs -- paranoia; this is an assertion.
1070 = make_constr_itbls dcs
1072 dcs = tyConDataCons tc
1073 n = tyConFamilySize tc
1076 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1078 -- Assumes constructors are numbered from zero, not one
1079 make_constr_itbls :: [DataCon] -> IO ItblEnv
1080 make_constr_itbls cons
1082 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1083 return (listToFM is)
1085 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1086 return (listToFM is)
1088 mk_vecret_itbl (dcon, conNo)
1089 = mk_itbl dcon conNo (vecret_entry conNo)
1090 mk_dirret_itbl (dcon, conNo)
1091 = mk_itbl dcon conNo mci_constr_entry
1093 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1094 mk_itbl dcon conNo entry_addr
1095 = let (tot_wds, ptr_wds, _)
1096 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1098 nptrs = tot_wds - ptr_wds
1099 itbl = StgInfoTable {
1100 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1101 tipe = fromIntegral cONSTR,
1102 srtlen = fromIntegral conNo,
1103 code0 = fromIntegral code0, code1 = fromIntegral code1,
1104 code2 = fromIntegral code2, code3 = fromIntegral code3,
1105 code4 = fromIntegral code4, code5 = fromIntegral code5,
1106 code6 = fromIntegral code6, code7 = fromIntegral code7
1108 -- Make a piece of code to jump to "entry_label".
1109 -- This is the only arch-dependent bit.
1110 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1111 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1113 -- B8 ZZ YY XX WW FF E0
1114 (code0,code1,code2,code3,code4,code5,code6,code7)
1115 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1116 byte 2 entry_addr_w, byte 3 entry_addr_w,
1120 entry_addr_w :: Word32
1121 entry_addr_w = fromIntegral (addrToInt entry_addr)
1123 do addr <- mallocElem itbl
1124 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1125 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1126 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1128 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1131 byte :: Int -> Word32 -> Word32
1132 byte 0 w = w .&. 0xFF
1133 byte 1 w = (w `shiftR` 8) .&. 0xFF
1134 byte 2 w = (w `shiftR` 16) .&. 0xFF
1135 byte 3 w = (w `shiftR` 24) .&. 0xFF
1138 vecret_entry 0 = mci_constr1_entry
1139 vecret_entry 1 = mci_constr2_entry
1140 vecret_entry 2 = mci_constr3_entry
1141 vecret_entry 3 = mci_constr4_entry
1142 vecret_entry 4 = mci_constr5_entry
1143 vecret_entry 5 = mci_constr6_entry
1144 vecret_entry 6 = mci_constr7_entry
1145 vecret_entry 7 = mci_constr8_entry
1147 -- entry point for direct returns for created constr itbls
1148 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1149 -- and the 8 vectored ones
1150 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1151 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1152 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1153 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1154 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1155 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1156 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1157 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1161 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1164 -- Ultra-minimalist version specially for constructors
1165 data StgInfoTable = StgInfoTable {
1170 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1174 instance Storable StgInfoTable where
1177 = (sum . map (\f -> f itbl))
1178 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1179 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1180 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1183 = (sum . map (\f -> f itbl))
1184 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1185 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1186 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1189 = do a1 <- store (ptrs itbl) a0
1190 a2 <- store (nptrs itbl) a1
1191 a3 <- store (tipe itbl) a2
1192 a4 <- store (srtlen itbl) a3
1193 a5 <- store (code0 itbl) a4
1194 a6 <- store (code1 itbl) a5
1195 a7 <- store (code2 itbl) a6
1196 a8 <- store (code3 itbl) a7
1197 a9 <- store (code4 itbl) a8
1198 aA <- store (code5 itbl) a9
1199 aB <- store (code6 itbl) aA
1200 aC <- store (code7 itbl) aB
1204 = do (a1,ptrs) <- load a0
1205 (a2,nptrs) <- load a1
1206 (a3,tipe) <- load a2
1207 (a4,srtlen) <- load a3
1208 (a5,code0) <- load a4
1209 (a6,code1) <- load a5
1210 (a7,code2) <- load a6
1211 (a8,code3) <- load a7
1212 (a9,code4) <- load a8
1213 (aA,code5) <- load a9
1214 (aB,code6) <- load aA
1215 (aC,code7) <- load aB
1216 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1217 srtlen = srtlen, tipe = tipe,
1218 code0 = code0, code1 = code1, code2 = code2,
1219 code3 = code3, code4 = code4, code5 = code5,
1220 code6 = code6, code7 = code7 }
1222 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1223 fieldSz sel x = sizeOf (sel x)
1225 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1226 fieldAl sel x = alignment (sel x)
1228 store :: Storable a => a -> Addr -> IO Addr
1229 store x addr = do poke addr x
1230 return (addr `plusAddr` fromIntegral (sizeOf x))
1232 load :: Storable a => Addr -> IO (Addr, a)
1233 load addr = do x <- peek addr
1234 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1236 -----------------------------------------------------------------------------q
1238 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1240 #endif /* #if __GLASGOW_HASKELL__ <= 408 */