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 )
37 linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
38 stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
43 import Id ( Id, idPrimRep )
46 import PrimOp ( PrimOp(..) )
47 import PrimRep ( PrimRep(..) )
48 import Literal ( Literal(..) )
49 import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
50 import DataCon ( DataCon, dataConTag, dataConRepArgTys )
51 import ClosureInfo ( mkVirtHeapOffsets )
52 import Name ( toRdrName )
56 import {-# SOURCE #-} MCI_make_constr
58 import IOExts ( unsafePerformIO ) -- ToDo: remove
59 import PrelGHC --( unsafeCoerce#, dataToTag#,
60 -- indexPtrOffClosure#, indexWordOffClosure# )
61 import IO ( hPutStr, stderr )
63 import PrelAddr ( Addr(..) )
64 import PrelFloat ( Float(..), Double(..) )
70 import GlaExts ( Int(..) )
71 import Module ( moduleNameFS )
73 import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
74 import Class ( Class, classTyCon )
78 import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
80 import Panic ( panic )
81 import OccName ( occNameString )
84 -- ---------------------------------------------------------------------------
85 -- Environments needed by the linker
86 -- ---------------------------------------------------------------------------
88 type ItblEnv = FiniteMap RdrName Addr
89 type ClosureEnv = FiniteMap RdrName HValue
91 -- ---------------------------------------------------------------------------
92 -- Run our STG program through the interpreter
93 -- ---------------------------------------------------------------------------
96 -- To be nuked at some point soon.
97 runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
99 -- the bindings need to have a binding for stgMain, and the
100 -- body of it had better represent something of type Int# -> Int#
101 runStgI tycons classes stgbinds
103 let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
107 = "-------------------- Unlinked Binds --------------------\n"
108 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
111 hPutStr stderr dbg_txt
113 (linked_binds, ie, ce) <-
114 linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
117 = "-------------------- Linked Binds --------------------\n"
118 ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
121 hPutStr stderr dbg_txt
124 = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
126 [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
129 = I# (evalI (AppII stgMain (LitI 0#))
130 emptyUFM{-initial de-}
135 -- ---------------------------------------------------------------------------
136 -- Convert STG to an unlinked interpretable
137 -- ---------------------------------------------------------------------------
139 -- visible from outside
140 stgToInterpSyn :: [StgBinding]
141 -> [TyCon] -> [Class]
142 -> IO ([UnlinkedIBind], ItblEnv)
143 stgToInterpSyn binds local_tycons local_classes
144 = do let ibinds = concatMap (translateBind emptyUniqSet) binds
145 let tycs = local_tycons ++ map classTyCon local_classes
146 itblenv <- mkITbls tycs
147 return (ibinds, itblenv)
150 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
151 translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
152 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
153 where ie' = addListToUniqSet ie (map fst vs_n_es)
155 isRec (StgNonRec _ _) = False
156 isRec (StgRec _) = True
158 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
159 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
162 rhsExpr = stg2expr (addListToUniqSet ie args) rhs
163 rhsRep = repOfStgExpr rhs
164 mkLambdas [] = rhsExpr
165 mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
166 rhs2expr ie (StgRhsCon ccs dcon args)
167 = conapp2expr ie dcon args
169 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
170 conapp2expr ie dcon args
171 = mkConApp con_rdrname reps exprs
173 con_rdrname = toRdrName dcon
174 exprs = map (arg2expr ie) inHeapOrder
175 reps = map repOfArg inHeapOrder
176 inHeapOrder = toHeapOrder args
178 toHeapOrder :: [StgArg] -> [StgArg]
180 = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
181 (rearranged, offsets) = unzip rearranged_w_offsets
185 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
187 -- Handle most common cases specially; do the rest with a generic
188 -- mechanism (deferred till later :)
189 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
190 mkConApp nm [] [] = ConApp nm
191 mkConApp nm [RepI] [a1] = ConAppI nm a1
192 mkConApp nm [RepP] [a1] = ConAppP nm a1
193 mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
194 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
195 mkConApp nm reps args
196 = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
198 mkLam RepP RepP = LamPP
199 mkLam RepI RepP = LamIP
200 mkLam RepP RepI = LamPI
201 mkLam RepI RepI = LamII
202 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
204 mkApp RepP RepP = AppPP
205 mkApp RepI RepP = AppIP
206 mkApp RepP RepI = AppPI
207 mkApp RepI RepI = AppII
208 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
211 repOfId = primRep2Rep . idPrimRep
216 -- genuine lifted types
219 -- all these are unboxed, fit into a word, and we assume they
220 -- all have the same call/return convention.
228 -- these are pretty dodgy: really pointers, but
229 -- we can't let the compiler build thunks with these reps.
230 ForeignObjRep -> RepP
231 StableNameRep -> RepP
236 other -> pprPanic "primRep2Rep" (ppr other)
238 repOfStgExpr :: StgExpr -> Rep
243 StgCase scrut live liveR bndr srt alts
244 -> case altRhss alts of
245 (a:_) -> repOfStgExpr a
246 [] -> panic "repOfStgExpr: no alts"
250 -> repOfApp ((deNoteType.repType.idType) var) (length args)
252 StgPrimApp op args res_ty
253 -> (primRep2Rep.typePrimRep) res_ty
255 StgLet binds body -> repOfStgExpr body
256 StgLetNoEscape live liveR binds body -> repOfStgExpr body
258 StgConApp con args -> RepP -- by definition
261 -> pprPanic "repOfStgExpr" (ppr other)
263 altRhss (StgAlgAlts ty alts def)
264 = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
265 altRhss (StgPrimAlts ty alts def)
266 = [rhs | (lit,rhs) <- alts] ++ defRhs def
269 defRhs (StgBindDefault rhs)
272 -- returns the Rep of the result of applying ty to n args.
273 repOfApp :: Type -> Int -> Rep
274 repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
275 repOfApp ty n = repOfApp (funResultTy ty) (n-1)
287 MachStr _ -> RepI -- because it's a ptr outside the heap
288 other -> pprPanic "repOfLit" (ppr lit)
290 lit2expr :: Literal -> UnlinkedIExpr
293 MachInt i -> case fromIntegral i of I# i -> LitI i
294 MachWord i -> case fromIntegral i of I# i -> LitI i
295 MachAddr i -> case fromIntegral i of I# i -> LitI i
296 MachChar i -> case fromIntegral i of I# i -> LitI i
297 MachFloat f -> case fromRational f of F# f -> LitF f
298 MachDouble f -> case fromRational f of D# f -> LitD f
301 CharStr s i -> LitI (addr2Int# s)
304 -- sigh, a string in the heap is no good to us. We need a
305 -- static C pointer, since the type of a string literal is
306 -- Addr#. So, copy the string into C land and introduce a
307 -- memory leak at the same time.
309 case unsafePerformIO (do a <- malloc (n+1);
310 strncpy a ba (fromIntegral n);
311 writeCharOffAddr a 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)
337 StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
338 | repOfStgExpr scrut == RepP
339 -> mkCaseAlg (repOfStgExpr stgexpr)
340 bndr (stg2expr ie scrut)
344 StgPrimApp op args res_ty
345 -> mkPrimOp (repOfStgExpr stgexpr)
346 op (map (arg2expr ie) args)
349 -> conapp2expr ie dcon args
351 StgLet binds@(StgNonRec v e) body
352 -> mkNonRec (repOfStgExpr stgexpr)
353 (head (translateBind ie binds))
354 (stg2expr (addOneToUniqSet ie v) body)
356 StgLet binds@(StgRec bs) body
357 -> mkRec (repOfStgExpr stgexpr)
358 (translateBind ie binds)
359 (stg2expr (addListToUniqSet ie (map fst bs)) body)
362 -> pprPanic "stg2expr" (ppr stgexpr)
365 = AltPrim (lit2expr lit) (stg2expr ie rhs)
366 doAlgAlt (dcon,vars,uses,rhs)
367 = AltAlg (dataConTag dcon - 1)
368 (map id2VaaRep (toHeapOrder vars))
369 (stg2expr (addListToUniqSet ie vars) rhs)
372 = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
373 (rearranged,offsets) = unzip rearranged_w_offsets
377 def2expr StgNoDefault = Nothing
378 def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
380 mkAppChain ie result_rep so_far []
382 mkAppChain ie result_rep so_far [a]
383 = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
384 mkAppChain ie result_rep so_far (a:as)
385 = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
387 mkCasePrim RepI = CasePrimI
388 mkCasePrim RepP = CasePrimP
390 mkCaseAlg RepI = CaseAlgI
391 mkCaseAlg RepP = CaseAlgP
393 -- any var that isn't in scope is turned into a Native
395 | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
396 | otherwise = Native (toRdrName var)
400 mkNonRec RepI = NonRecI
401 mkNonRec RepP = NonRecP
403 mkPrimOp RepI = PrimOpI
404 mkPrimOp RepP = PrimOpP
406 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
407 arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
408 arg2expr ie (StgLitArg lit) = lit2expr lit
409 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
411 repOfArg :: StgArg -> Rep
412 repOfArg (StgVarArg v) = repOfId v
413 repOfArg (StgLitArg lit) = repOfLit lit
414 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
416 id2VaaRep var = (var, repOfId var)
419 -- ---------------------------------------------------------------------------
420 -- Link interpretables into something we can run
421 -- ---------------------------------------------------------------------------
423 linkIModules :: ClosureEnv -- incoming global closure env; returned updated
424 -> ItblEnv -- incoming global itbl env; returned updated
425 -> [([UnlinkedIBind], ItblEnv)]
426 -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
427 linkIModules gce gie mods = do
428 let (bindss, ies) = unzip mods
429 binds = concat bindss
430 top_level_binders = map (toRdrName.binder) binds
431 final_gie = foldr plusFM gie ies
434 new_gce = addListToFM gce (zip top_level_binders new_rhss)
435 new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
436 ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
437 new_binds = linkIBinds final_gie new_gce binds
439 return (new_binds, final_gie, new_gce)
442 -- We're supposed to augment the environments with the values of any
443 -- external functions/info tables we need as we go along, but that's a
444 -- lot of hassle so for now I'll look up external things as they crop
445 -- up and not cache them in the source symbol tables. The interpreted
446 -- code will still be referenced in the source symbol tables.
448 -- JRS 001025: above comment is probably out of date ... interpret
451 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
452 linkIBinds ie ce binds = map (linkIBind ie ce) binds
454 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
456 linkIExpr ie ce expr = case expr of
458 CaseAlgP bndr expr alts dflt ->
459 CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
460 (linkDefault ie ce dflt)
462 CaseAlgI bndr expr alts dflt ->
463 CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
464 (linkDefault ie ce dflt)
466 CasePrimP bndr expr alts dflt ->
467 CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
468 (linkDefault ie ce dflt)
470 CasePrimI bndr expr alts dflt ->
471 CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
472 (linkDefault ie ce dflt)
475 ConApp (lookupCon ie con)
478 ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
481 ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
483 ConAppPP con arg0 arg1 ->
484 ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
486 ConAppPPP con arg0 arg1 arg2 ->
487 ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
488 (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
490 PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
491 PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
493 NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
494 RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
496 NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
497 RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
503 Native var -> lookupNative ce var
505 VarP v -> lookupVar ce VarP v
506 VarI v -> lookupVar ce VarI v
508 LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
509 LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
510 LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
511 LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
513 AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
514 AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
515 AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
516 AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
519 case lookupFM ie con of
522 -- try looking up in the object files.
524 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
526 Nothing -> pprPanic "linkIExpr" (ppr con)
528 lookupNative ce var =
529 case lookupFM ce var of
532 -- try looking up in the object files.
533 let lbl = (rdrNameToCLabel var "closure")
534 addr = unsafePerformIO (lookupSymbol lbl) in
535 case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
536 Just (A# addr) -> Native (unsafeCoerce# addr)
537 Nothing -> pprPanic "linkIExpr" (ppr var)
539 -- some VarI/VarP refer to top-level interpreted functions; we change
540 -- them into Natives here.
542 case lookupFM ce (toRdrName v) of
546 -- HACK!!! ToDo: cleaner
547 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
548 rdrNameToCLabel rn suffix =
549 _UNPK_(moduleNameFS (rdrNameModule rn))
550 ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
552 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
553 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
555 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
556 linkPrimAlt ie ce (AltPrim lit rhs)
557 = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
559 linkDefault ie ce Nothing = Nothing
560 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
562 -- ---------------------------------------------------------------------------
563 -- The interpreter proper
564 -- ---------------------------------------------------------------------------
566 -- The dynamic environment contains everything boxed.
567 -- eval* functions which look up values in it will know the
568 -- representation of the thing they are looking up, so they
569 -- can cast/unbox it as necessary.
571 -- ---------------------------------------------------------------------------
572 -- Evaluator for things of boxed (pointer) representation
573 -- ---------------------------------------------------------------------------
575 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
579 -- | trace ("evalP: " ++ showExprTag expr) False
580 | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
581 = error "evalP: ?!?!"
584 evalP (Native p) de = unsafeCoerce# p
586 -- First try the dynamic env. If that fails, assume it's a top-level
587 -- binding and look in the static env. That gives an Expr, which we
588 -- must convert to a boxed thingy by applying evalP to it. Because
589 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
590 -- CAFs), it's always safe to use evalP.
592 = case lookupUFM de v of
594 Nothing -> error ("evalP: lookupUFM " ++ show v)
596 -- Deal with application of a function returning a pointer rep
597 -- to arguments of any persuasion. Note that the function itself
598 -- always has pointer rep.
599 evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
600 evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
601 evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
602 evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
604 -- Lambdas always return P-rep, but we need to do different things
605 -- depending on both the argument and result representations.
607 = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
609 = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
611 = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
613 = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
615 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
617 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
619 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
621 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
623 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
625 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
627 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
629 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
631 = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
633 = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
635 = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
637 = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
640 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
641 -- except in the sense that we go on and evaluate the body with whichever
642 -- evaluator was used for the expression as a whole.
643 evalP (NonRecP bind e) de
644 = evalP e (augment_nonrec bind de)
645 evalP (RecP binds b) de
646 = evalP b (augment_rec binds de)
647 evalP (CaseAlgP bndr expr alts def) de
648 = case helper_caseAlg bndr expr alts def de of
649 (rhs, de') -> evalP rhs de'
650 evalP (CasePrimP bndr expr alts def) de
651 = case helper_casePrim bndr expr alts def de of
652 (rhs, de') -> evalP rhs de'
655 -- ConApp can only be handled by evalP
656 evalP (ConApp itbl args) se de
659 -- This appalling hack suggested (gleefully) by SDM
660 -- It is not well typed (needless to say?)
661 loop :: [Expr] -> boxed
663 = trace "loop-empty" (
664 case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
667 = trace "loop-not-empty" (
669 RepI -> case evalI a de of i# -> loop as i#
670 RepP -> let p = evalP a de in loop as p
674 evalP (ConAppI (A# itbl) a1) de
675 = case evalI a1 de of i1 -> mci_make_constrI itbl i1
677 evalP (ConApp (A# itbl)) de
678 = mci_make_constr itbl
680 evalP (ConAppP (A# itbl) a1) de
681 = let p1 = evalP a1 de
682 in mci_make_constrP itbl p1
684 evalP (ConAppPP (A# itbl) a1 a2) de
685 = let p1 = evalP a1 de
687 in mci_make_constrPP itbl p1 p2
689 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
690 = let p1 = evalP a1 de
693 in mci_make_constrPPP itbl p1 p2 p3
698 = error ("evalP: unhandled case: " ++ showExprTag other)
700 --------------------------------------------------------
701 --- Evaluator for things of Int# representation
702 --------------------------------------------------------
704 -- Evaluate something which has an unboxed Int rep
705 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
708 -- | trace ("evalI: " ++ showExprTag expr) False
709 | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
710 = error "evalI: ?!?!"
712 evalI (LitI i#) de = i#
715 case lookupUFM de v of
716 Just e -> case unsafeCoerce# e of I# i -> i
717 Nothing -> error ("evalI: lookupUFM " ++ show v)
719 -- Deal with application of a function returning an Int# rep
720 -- to arguments of any persuasion. Note that the function itself
721 -- always has pointer rep.
722 evalI (AppII e1 e2) de
723 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
724 evalI (AppPI e1 e2) de
725 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
726 evalI (AppFI e1 e2) de
727 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
728 evalI (AppDI e1 e2) de
729 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
731 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
732 -- except in the sense that we go on and evaluate the body with whichever
733 -- evaluator was used for the expression as a whole.
734 evalI (NonRecI bind b) de
735 = evalI b (augment_nonrec bind de)
736 evalI (RecI binds b) de
737 = evalI b (augment_rec binds de)
738 evalI (CaseAlgI bndr expr alts def) de
739 = case helper_caseAlg bndr expr alts def de of
740 (rhs, de') -> evalI rhs de'
741 evalI (CasePrimI bndr expr alts def) de
742 = case helper_casePrim bndr expr alts def de of
743 (rhs, de') -> evalI rhs de'
745 -- evalI can't be applied to a lambda term, by defn, since those
748 evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
749 evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
751 --evalI (NonRec (IBind v e) b) de
752 -- = evalI b (augment de v (eval e de))
755 = error ("evalI: unhandled case: " ++ showExprTag other)
757 --------------------------------------------------------
758 --- Evaluator for things of Float# representation
759 --------------------------------------------------------
761 -- Evaluate something which has an unboxed Int rep
762 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
765 -- | trace ("evalF: " ++ showExprTag expr) False
766 | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
767 = error "evalF: ?!?!"
769 evalF (LitF f#) de = f#
772 case lookupUFM de v of
773 Just e -> case unsafeCoerce# e of F# i -> i
774 Nothing -> error ("evalF: lookupUFM " ++ show v)
776 -- Deal with application of a function returning an Int# rep
777 -- to arguments of any persuasion. Note that the function itself
778 -- always has pointer rep.
779 evalF (AppIF e1 e2) de
780 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
781 evalF (AppPF e1 e2) de
782 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
783 evalF (AppFF e1 e2) de
784 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
785 evalF (AppDF e1 e2) de
786 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
788 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
789 -- except in the sense that we go on and evaluate the body with whichever
790 -- evaluator was used for the expression as a whole.
791 evalF (NonRecF bind b) de
792 = evalF b (augment_nonrec bind de)
793 evalF (RecF binds b) de
794 = evalF b (augment_rec binds de)
795 evalF (CaseAlgF bndr expr alts def) de
796 = case helper_caseAlg bndr expr alts def de of
797 (rhs, de') -> evalF rhs de'
798 evalF (CasePrimF bndr expr alts def) de
799 = case helper_casePrim bndr expr alts def de of
800 (rhs, de') -> evalF rhs de'
802 -- evalF can't be applied to a lambda term, by defn, since those
805 evalF (PrimOpF op _) de
806 = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
809 = error ("evalF: unhandled case: " ++ showExprTag other)
811 --------------------------------------------------------
812 --- Evaluator for things of Double# representation
813 --------------------------------------------------------
815 -- Evaluate something which has an unboxed Int rep
816 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
819 -- | trace ("evalD: " ++ showExprTag expr) False
820 | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
821 = error "evalD: ?!?!"
823 evalD (LitD d#) de = d#
826 case lookupUFM de v of
827 Just e -> case unsafeCoerce# e of D# i -> i
828 Nothing -> error ("evalD: lookupUFM " ++ show v)
830 -- Deal with application of a function returning an Int# rep
831 -- to arguments of any persuasion. Note that the function itself
832 -- always has pointer rep.
833 evalD (AppID e1 e2) de
834 = unsafeCoerce# (evalP e1 de) (evalI e2 de)
835 evalD (AppPD e1 e2) de
836 = unsafeCoerce# (evalP e1 de) (evalP e2 de)
837 evalD (AppFD e1 e2) de
838 = unsafeCoerce# (evalP e1 de) (evalF e2 de)
839 evalD (AppDD e1 e2) de
840 = unsafeCoerce# (evalP e1 de) (evalD e2 de)
842 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
843 -- except in the sense that we go on and evaluate the body with whichever
844 -- evaluator was used for the expression as a whole.
845 evalD (NonRecD bind b) de
846 = evalD b (augment_nonrec bind de)
847 evalD (RecD binds b) de
848 = evalD b (augment_rec binds de)
849 evalD (CaseAlgD bndr expr alts def) de
850 = case helper_caseAlg bndr expr alts def de of
851 (rhs, de') -> evalD rhs de'
852 evalD (CasePrimD bndr expr alts def) de
853 = case helper_casePrim bndr expr alts def de of
854 (rhs, de') -> evalD rhs de'
856 -- evalD can't be applied to a lambda term, by defn, since those
859 evalD (PrimOpD op _) de
860 = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
863 = error ("evalD: unhandled case: " ++ showExprTag other)
865 --------------------------------------------------------
866 --- Helper bits and pieces
867 --------------------------------------------------------
869 -- Find the Rep of any Expr
870 repOf :: LinkedIExpr -> Rep
872 repOf (LamPP _ _) = RepP
873 repOf (LamPI _ _) = RepP
874 repOf (LamPF _ _) = RepP
875 repOf (LamPD _ _) = RepP
876 repOf (LamIP _ _) = RepP
877 repOf (LamII _ _) = RepP
878 repOf (LamIF _ _) = RepP
879 repOf (LamID _ _) = RepP
880 repOf (LamFP _ _) = RepP
881 repOf (LamFI _ _) = RepP
882 repOf (LamFF _ _) = RepP
883 repOf (LamFD _ _) = RepP
884 repOf (LamDP _ _) = RepP
885 repOf (LamDI _ _) = RepP
886 repOf (LamDF _ _) = RepP
887 repOf (LamDD _ _) = RepP
889 repOf (AppPP _ _) = RepP
890 repOf (AppPI _ _) = RepI
891 repOf (AppPF _ _) = RepF
892 repOf (AppPD _ _) = RepD
893 repOf (AppIP _ _) = RepP
894 repOf (AppII _ _) = RepI
895 repOf (AppIF _ _) = RepF
896 repOf (AppID _ _) = RepD
897 repOf (AppFP _ _) = RepP
898 repOf (AppFI _ _) = RepI
899 repOf (AppFF _ _) = RepF
900 repOf (AppFD _ _) = RepD
901 repOf (AppDP _ _) = RepP
902 repOf (AppDI _ _) = RepI
903 repOf (AppDF _ _) = RepF
904 repOf (AppDD _ _) = RepD
906 repOf (NonRecP _ _) = RepP
907 repOf (NonRecI _ _) = RepI
908 repOf (NonRecF _ _) = RepF
909 repOf (NonRecD _ _) = RepD
911 repOf (LitI _) = RepI
912 repOf (LitF _) = RepF
913 repOf (LitD _) = RepD
915 repOf (VarP _) = RepI
916 repOf (VarI _) = RepI
917 repOf (VarF _) = RepF
918 repOf (VarD _) = RepD
920 repOf (PrimOpP _ _) = RepP
921 repOf (PrimOpI _ _) = RepI
922 repOf (PrimOpF _ _) = RepF
923 repOf (PrimOpD _ _) = RepD
925 repOf (ConApp _) = RepP
926 repOf (ConAppI _ _) = RepP
927 repOf (ConAppP _ _) = RepP
928 repOf (ConAppPP _ _ _) = RepP
929 repOf (ConAppPPP _ _ _ _) = RepP
931 repOf (CaseAlgP _ _ _ _) = RepP
932 repOf (CaseAlgI _ _ _ _) = RepI
933 repOf (CaseAlgF _ _ _ _) = RepF
934 repOf (CaseAlgD _ _ _ _) = RepD
936 repOf (CasePrimP _ _ _ _) = RepP
937 repOf (CasePrimI _ _ _ _) = RepI
938 repOf (CasePrimF _ _ _ _) = RepF
939 repOf (CasePrimD _ _ _ _) = RepD
942 = error ("repOf: unhandled case: " ++ showExprTag other)
944 -- how big (in words) is one of these
945 repSizeW :: Rep -> Int
950 -- Evaluate an expression, using the appropriate evaluator,
951 -- then box up the result. Note that it's only safe to use this
952 -- to create values to put in the environment. You can't use it
953 -- to create a value which might get passed to native code since that
954 -- code will have no idea that unboxed things have been boxed.
955 eval :: LinkedIExpr -> UniqFM boxed -> boxed
958 RepI -> unsafeCoerce# (I# (evalI expr de))
959 RepP -> evalP expr de
960 RepF -> unsafeCoerce# (F# (evalF expr de))
961 RepD -> unsafeCoerce# (D# (evalD expr de))
963 -- Evaluate the scrutinee of a case, select an alternative,
964 -- augment the environment appropriately, and return the alt
965 -- and the augmented environment.
966 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
968 -> (LinkedIExpr, UniqFM boxed)
969 helper_caseAlg bndr expr alts def de
970 = let exprEv = evalP expr de
972 exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
973 case select_altAlg (tagOf exprEv) alts def of
974 (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
977 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
979 -> (LinkedIExpr, UniqFM boxed)
980 helper_casePrim bndr expr alts def de
982 -- Umm, can expr have any other rep? Yes ...
983 -- CharRep, DoubleRep, FloatRep. What about string reps?
984 RepI -> case evalI expr de of
985 i# -> (select_altPrim alts def (LitI i#),
986 addToUFM de bndr (unsafeCoerce# (I# i#)))
989 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
990 augment_from_constr de con ([],offset)
992 augment_from_constr de con ((v,rep):vs,offset)
995 RepP -> indexPtrOffClosure con offset
996 RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
998 augment_from_constr (addToUFM de v v_binding) con
999 (vs,offset + repSizeW rep)
1001 -- Augment the environment for a non-recursive let.
1002 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1003 augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
1005 -- Augment the environment for a recursive let.
1006 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1007 augment_rec binds de
1008 = let vars = map binder binds
1009 rhss = map bindee binds
1010 rhs_vs = map (\rhs -> eval rhs de') rhss
1011 de' = addListToUFM de (zip vars rhs_vs)
1015 -- a must be a constructor?
1017 tagOf x = I# (dataToTag# x)
1019 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1020 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1021 select_altAlg tag [] (Just def) = ([],def)
1022 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1025 else select_altAlg tag alts def
1027 -- literal may only be a literal, not an arbitrary expression
1028 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1029 select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
1030 select_altPrim [] (Just def) literal = def
1031 select_altPrim ((AltPrim lit rhs):alts) def literal
1032 = if eqLits lit literal
1034 else select_altPrim alts def literal
1036 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1039 -- a is a constructor
1040 indexPtrOffClosure :: a -> Int -> b
1041 indexPtrOffClosure con (I# offset)
1042 = case indexPtrOffClosure# con offset of (# x #) -> x
1044 indexIntOffClosure :: a -> Int -> Int#
1045 indexIntOffClosure con (I# offset)
1046 = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1049 ------------------------------------------------------------------------
1050 --- Manufacturing of info tables for DataCons defined in this module ---
1051 ------------------------------------------------------------------------
1053 -- Make info tables for the data decls in this module
1054 mkITbls :: [TyCon] -> IO ItblEnv
1055 mkITbls [] = return emptyFM
1056 mkITbls (tc:tcs) = do itbls <- mkITbl tc
1057 itbls2 <- mkITbls tcs
1058 return (itbls `plusFM` itbls2)
1060 mkITbl :: TyCon -> IO ItblEnv
1062 -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1064 | not (isDataTyCon tc)
1066 | n == length dcs -- paranoia; this is an assertion.
1067 = make_constr_itbls dcs
1069 dcs = tyConDataCons tc
1070 n = tyConFamilySize tc
1073 cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
1075 -- Assumes constructors are numbered from zero, not one
1076 make_constr_itbls :: [DataCon] -> IO ItblEnv
1077 make_constr_itbls cons
1079 = do is <- mapM mk_vecret_itbl (zip cons [0..])
1080 return (listToFM is)
1082 = do is <- mapM mk_dirret_itbl (zip cons [0..])
1083 return (listToFM is)
1085 mk_vecret_itbl (dcon, conNo)
1086 = mk_itbl dcon conNo (vecret_entry conNo)
1087 mk_dirret_itbl (dcon, conNo)
1088 = mk_itbl dcon conNo mci_constr_entry
1090 mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
1091 mk_itbl dcon conNo entry_addr
1092 = let (tot_wds, ptr_wds, _)
1093 = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1095 nptrs = tot_wds - ptr_wds
1096 itbl = StgInfoTable {
1097 ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1098 tipe = fromIntegral cONSTR,
1099 srtlen = fromIntegral conNo,
1100 code0 = fromIntegral code0, code1 = fromIntegral code1,
1101 code2 = fromIntegral code2, code3 = fromIntegral code3,
1102 code4 = fromIntegral code4, code5 = fromIntegral code5,
1103 code6 = fromIntegral code6, code7 = fromIntegral code7
1105 -- Make a piece of code to jump to "entry_label".
1106 -- This is the only arch-dependent bit.
1107 -- On x86, if entry_label has an address 0xWWXXYYZZ,
1108 -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
1110 -- B8 ZZ YY XX WW FF E0
1111 (code0,code1,code2,code3,code4,code5,code6,code7)
1112 = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1113 byte 2 entry_addr_w, byte 3 entry_addr_w,
1117 entry_addr_w :: Word32
1118 entry_addr_w = fromIntegral (addrToInt entry_addr)
1120 do addr <- mallocElem itbl
1121 putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1122 putStrLn ("# ptrs of itbl is " ++ show ptrs)
1123 putStrLn ("# nptrs of itbl is " ++ show nptrs)
1125 return (toRdrName dcon, intToAddr (addrToInt addr + 8))
1128 byte :: Int -> Word32 -> Word32
1129 byte 0 w = w .&. 0xFF
1130 byte 1 w = (w `shiftR` 8) .&. 0xFF
1131 byte 2 w = (w `shiftR` 16) .&. 0xFF
1132 byte 3 w = (w `shiftR` 24) .&. 0xFF
1135 vecret_entry 0 = mci_constr1_entry
1136 vecret_entry 1 = mci_constr2_entry
1137 vecret_entry 2 = mci_constr3_entry
1138 vecret_entry 3 = mci_constr4_entry
1139 vecret_entry 4 = mci_constr5_entry
1140 vecret_entry 5 = mci_constr6_entry
1141 vecret_entry 6 = mci_constr7_entry
1142 vecret_entry 7 = mci_constr8_entry
1144 -- entry point for direct returns for created constr itbls
1145 foreign label "mci_constr_entry" mci_constr_entry :: Addr
1146 -- and the 8 vectored ones
1147 foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
1148 foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
1149 foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
1150 foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
1151 foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
1152 foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
1153 foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
1154 foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
1158 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1161 -- Ultra-minimalist version specially for constructors
1162 data StgInfoTable = StgInfoTable {
1167 code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1171 instance Storable StgInfoTable where
1174 = (sum . map (\f -> f itbl))
1175 [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1176 fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1177 fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1180 = (sum . map (\f -> f itbl))
1181 [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1182 fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1183 fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1186 = do a1 <- store (ptrs itbl) a0
1187 a2 <- store (nptrs itbl) a1
1188 a3 <- store (tipe itbl) a2
1189 a4 <- store (srtlen itbl) a3
1190 a5 <- store (code0 itbl) a4
1191 a6 <- store (code1 itbl) a5
1192 a7 <- store (code2 itbl) a6
1193 a8 <- store (code3 itbl) a7
1194 a9 <- store (code4 itbl) a8
1195 aA <- store (code5 itbl) a9
1196 aB <- store (code6 itbl) aA
1197 aC <- store (code7 itbl) aB
1201 = do (a1,ptrs) <- load a0
1202 (a2,nptrs) <- load a1
1203 (a3,tipe) <- load a2
1204 (a4,srtlen) <- load a3
1205 (a5,code0) <- load a4
1206 (a6,code1) <- load a5
1207 (a7,code2) <- load a6
1208 (a8,code3) <- load a7
1209 (a9,code4) <- load a8
1210 (aA,code5) <- load a9
1211 (aB,code6) <- load aA
1212 (aC,code7) <- load aB
1213 return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1214 srtlen = srtlen, tipe = tipe,
1215 code0 = code0, code1 = code1, code2 = code2,
1216 code3 = code3, code4 = code4, code5 = code5,
1217 code6 = code6, code7 = code7 }
1219 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1220 fieldSz sel x = sizeOf (sel x)
1222 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1223 fieldAl sel x = alignment (sel x)
1225 store :: Storable a => a -> Addr -> IO Addr
1226 store x addr = do poke addr x
1227 return (addr `plusAddr` fromIntegral (sizeOf x))
1229 load :: Storable a => Addr -> IO (Addr, a)
1230 load addr = do x <- peek addr
1231 return (addr `plusAddr` fromIntegral (sizeOf x), x)
1233 -----------------------------------------------------------------------------q
1235 foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
1237 #endif /* #if __GLASGOW_HASKELL__ <= 408 */