\begin{code}
module StgInterp (
- ClosureEnv, ItblEnv,
- linkIModules,
- stgToInterpSyn,
+
+ ClosureEnv, ItblEnv,
+ filterRdrNameEnv, -- :: [ModuleName] -> FiniteMap RdrName a
+ -- -> FiniteMap RdrName a
+
+ linkIModules, -- :: ItblEnv -> ClosureEnv
+ -- -> [([UnlinkedIBind], ItblEnv)]
+ -- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
+
+ iExprToHValue, -- :: ItblEnv -> ClosureEnv
+ -- -> UnlinkedIExpr -> HValue
+
+ stgBindsToInterpSyn,-- :: [StgBinding]
+ -- -> [TyCon] -> [Class]
+ -- -> IO ([UnlinkedIBind], ItblEnv)
+
+ stgExprToInterpSyn, -- :: StgExpr
+ -- -> IO UnlinkedIExpr
+
+ interp -- :: LinkedIExpr -> HValue
) where
{- -----------------------------------------------------------------------------
import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
import DataCon ( DataCon, dataConTag, dataConRepArgTys )
import ClosureInfo ( mkVirtHeapOffsets )
+import Module ( ModuleName )
import Name ( toRdrName )
import UniqFM
import UniqSet
import FiniteMap
import Panic ( panic )
import OccName ( occNameString )
+import ErrUtils ( showPass )
+import CmdLineOpts ( DynFlags )
import Foreign
import CTypes
+import IO
-- ---------------------------------------------------------------------------
-- Environments needed by the linker
type ClosureEnv = FiniteMap RdrName HValue
emptyClosureEnv = emptyFM
+-- remove all entries for a given set of modules from the environment
+filterRdrNameEnv :: [ModuleName] -> FiniteMap RdrName a -> FiniteMap RdrName a
+filterRdrNameEnv mods env
+ = filterFM (\n _ -> rdrNameModule n `notElem` mods) env
+
-- ---------------------------------------------------------------------------
--- Run our STG program through the interpreter
+-- Turn an UnlinkedIExpr into a value we can run, for the interpreter
-- ---------------------------------------------------------------------------
-#if 0
--- To be nuked at some point soon.
-runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
-
--- the bindings need to have a binding for stgMain, and the
--- body of it had better represent something of type Int# -> Int#
-runStgI tycons classes stgbinds
- = do
- let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
-
-{-
- let dbg_txt
- = "-------------------- Unlinked Binds --------------------\n"
- ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
- unlinked_binds))
-
- hPutStr stderr dbg_txt
--}
- (linked_binds, ie, ce) <-
- linkIModules emptyFM emptyFM [(tycons,unlinked_binds)]
-
- let dbg_txt
- = "-------------------- Linked Binds --------------------\n"
- ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ')
- linked_binds))
-
- hPutStr stderr dbg_txt
-
- let stgMain
- = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of
- (b:_) -> b
- [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n"
-
- let result
- = I# (evalI (AppII stgMain (LitI 0#))
- emptyUFM{-initial de-}
- )
- return result
-#endif
+iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
+iExprToHValue ie ce expr = return (interp (linkIExpr ie ce expr))
-- ---------------------------------------------------------------------------
-- Convert STG to an unlinked interpretable
-- ---------------------------------------------------------------------------
-- visible from outside
-stgToInterpSyn :: [StgBinding]
- -> [TyCon] -> [Class]
- -> IO ([UnlinkedIBind], ItblEnv)
-stgToInterpSyn binds local_tycons local_classes
- = do let ibinds = concatMap (translateBind emptyUniqSet) binds
+stgBindsToInterpSyn :: DynFlags
+ -> [StgBinding]
+ -> [TyCon] -> [Class]
+ -> IO ([UnlinkedIBind], ItblEnv)
+stgBindsToInterpSyn dflags binds local_tycons local_classes
+ = do showPass dflags "StgToInterp"
+ let ibinds = concatMap (translateBind emptyUniqSet) binds
let tycs = local_tycons ++ map classTyCon local_classes
itblenv <- mkITbls tycs
return (ibinds, itblenv)
+stgExprToInterpSyn :: DynFlags
+ -> StgExpr
+ -> IO UnlinkedIExpr
+stgExprToInterpSyn dflags expr
+ = do showPass dflags "StgToInterp"
+ return (stg2expr emptyUniqSet expr)
translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
ArrayRep -> RepP
ByteArrayRep -> RepP
+ FloatRep -> RepF
+ DoubleRep -> RepD
+
other -> pprPanic "primRep2Rep" (ppr other)
repOfStgExpr :: StgExpr -> Rep
other
-> pprPanic "repOfStgExpr" (ppr other)
where
- altRhss (StgAlgAlts ty alts def)
+ altRhss (StgAlgAlts tycon alts def)
= [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
- altRhss (StgPrimAlts ty alts def)
+ altRhss (StgPrimAlts tycon alts def)
= [rhs | (lit,rhs) <- alts] ++ defRhs def
defRhs StgNoDefault
= []
-- Addr#. So, copy the string into C land and introduce a
-- memory leak at the same time.
let n = I# l in
- case unsafePerformIO (do a <- mallocBytes (n+1);
- strncpy a ba (fromIntegral n);
- pokeByteOff a n '\0'
- case a of { Ptr a -> return a })
+ -- CAREFUL! Chars are 32 bits in ghc 4.09+
+ case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
+ strncpy a ba (fromIntegral n)
+ writeCharOffAddr addr n '\0'
+ return addr)
of A# a -> LitI (addr2Int# a)
_ -> error "StgInterp.lit2expr: unhandled string constant type"
(map doPrimAlt alts)
(def2expr def)
- StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
+ StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
| repOfStgExpr scrut == RepP
-> mkCaseAlg (repOfStgExpr stgexpr)
bndr (stg2expr ie scrut)
(translateBind ie binds)
(stg2expr (addListToUniqSet ie (map fst bs)) body)
- other
+ -- treat let-no-escape just like let.
+ StgLetNoEscape _ _ binds body
+ -> stg2expr ie (StgLet binds body)
+
+ other
-> pprPanic "stg2expr" (ppr stgexpr)
where
doPrimAlt (lit,rhs)
-- any var that isn't in scope is turned into a Native
mkVar ie rep var
- | var `elementOfUniqSet` ie = case rep of { RepI -> VarI; RepP -> VarP } $ var
+ | var `elementOfUniqSet` ie =
+ (case rep of
+ RepI -> VarI
+ RepF -> VarF
+ RepD -> VarD
+ RepP -> VarP) var
| otherwise = Native (toRdrName var)
mkRec RepI = RecI
-- Link interpretables into something we can run
-- ---------------------------------------------------------------------------
-linkIModules :: ClosureEnv -- incoming global closure env; returned updated
- -> ItblEnv -- incoming global itbl env; returned updated
+linkIModules :: ItblEnv -- incoming global itbl env; returned updated
+ -> ClosureEnv -- incoming global closure env; returned updated
-> [([UnlinkedIBind], ItblEnv)]
-> IO ([LinkedIBind], ItblEnv, ClosureEnv)
-linkIModules gce gie mods = do
+linkIModules gie gce mods = do
let (bindss, ies) = unzip mods
binds = concat bindss
top_level_binders = map (toRdrName.binder) binds
let {-rec-}
new_gce = addListToFM gce (zip top_level_binders new_rhss)
new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
- ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
+ --vvvvvvvvv----------------------------------------^^^^^^^^^-- circular
new_binds = linkIBinds final_gie new_gce binds
return (new_binds, final_gie, new_gce)
-- up and not cache them in the source symbol tables. The interpreted
-- code will still be referenced in the source symbol tables.
--- JRS 001025: above comment is probably out of date ... interpret
--- with care.
-
linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
linkIBinds ie ce binds = map (linkIBind ie ce) binds
linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
+linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> LinkedIExpr
linkIExpr ie ce expr = case expr of
CaseAlgP bndr expr alts dflt ->
-- Evaluator for things of boxed (pointer) representation
-- ---------------------------------------------------------------------------
+interp :: LinkedIExpr -> HValue
+interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
+
evalP :: LinkedIExpr -> UniqFM boxed -> boxed
{-
-- Evaluate something which has an unboxed Int rep
evalI :: LinkedIExpr -> UniqFM boxed -> Int#
+{-
evalI expr de
-- | trace ("evalI: " ++ showExprTag expr) False
| trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
= error "evalI: ?!?!"
+-}
evalI (LitI i#) de = i#
-- Evaluate something which has an unboxed Int rep
evalF :: LinkedIExpr -> UniqFM boxed -> Float#
+{-
evalF expr de
-- | trace ("evalF: " ++ showExprTag expr) False
| trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
= error "evalF: ?!?!"
+-}
evalF (LitF f#) de = f#
-- Evaluate something which has an unboxed Int rep
evalD :: LinkedIExpr -> UniqFM boxed -> Double#
+{-
evalD expr de
-- | trace ("evalD: " ++ showExprTag expr) False
| trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
= error "evalD: ?!?!"
+-}
evalD (LitD d#) de = d#
repOf (NonRecF _ _) = RepF
repOf (NonRecD _ _) = RepD
+repOf (RecP _ _) = RepP
+repOf (RecI _ _) = RepI
+repOf (RecF _ _) = RepF
+repOf (RecD _ _) = RepD
+
repOf (LitI _) = RepI
repOf (LitF _) = RepF
repOf (LitD _) = RepD
+repOf (Native _) = RepP
+
repOf (VarP _) = RepI
repOf (VarI _) = RepI
repOf (VarF _) = RepF
vecret_entry 7 = mci_constr8_entry
-- entry point for direct returns for created constr itbls
-foreign label "mci_constr_entry" mci_constr_entry :: Addr
+foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
-- and the 8 vectored ones
-foreign label "mci_constr1_entry" mci_constr1_entry :: Addr
-foreign label "mci_constr2_entry" mci_constr2_entry :: Addr
-foreign label "mci_constr3_entry" mci_constr3_entry :: Addr
-foreign label "mci_constr4_entry" mci_constr4_entry :: Addr
-foreign label "mci_constr5_entry" mci_constr5_entry :: Addr
-foreign label "mci_constr6_entry" mci_constr6_entry :: Addr
-foreign label "mci_constr7_entry" mci_constr7_entry :: Addr
-foreign label "mci_constr8_entry" mci_constr8_entry :: Addr
+foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
+foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
+foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
+foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
+foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
+foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
+foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
+foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
projects / ghc-hetmet.git / blobdiff