\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
{- -----------------------------------------------------------------------------
#include "HsVersions.h"
-#if __GLASGOW_HASKELL__ <= 408
-
-import Panic ( panic )
-import RdrName ( RdrName )
-import PrelAddr ( Addr )
-import FiniteMap ( FiniteMap )
-import InterpSyn ( HValue )
-
-type ItblEnv = FiniteMap RdrName Addr
-type ClosureEnv = FiniteMap RdrName HValue
-linkIModules = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
-stgToInterpSyn = panic "StgInterp.linkIModules: this hsc was not built with an interpreter"
-
-#else
-
import Linker
import Id ( Id, idPrimRep )
import Outputable
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
-- indexPtrOffClosure#, indexWordOffClosure# )
import PrelAddr ( Addr(..) )
import PrelFloat ( Float(..), Double(..) )
-import Word
import Bits
-import Storable
-import CTypes
import FastString
import GlaExts ( Int(..) )
import Module ( moduleNameFS )
import InterpSyn
import StgSyn
import Addr
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc )
+import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isUnqual )
import FiniteMap
import Panic ( panic )
import OccName ( occNameString )
+import ErrUtils ( showPass, dumpIfSet_dyn )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Foreign
+import CTypes
+import IO
-- ---------------------------------------------------------------------------
-- Environments needed by the linker
-- ---------------------------------------------------------------------------
-type ItblEnv = FiniteMap RdrName Addr
+type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable)
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
+ dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
+ "Convert To InterpSyn" (vcat (map pprIBind ibinds))
itblenv <- mkITbls tycs
return (ibinds, itblenv)
+stgExprToInterpSyn :: DynFlags
+ -> StgExpr
+ -> IO UnlinkedIExpr
+stgExprToInterpSyn dflags expr
+ = do showPass dflags "StgToInterp"
+ let iexpr = stg2expr emptyUniqSet expr
+ dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
+ "Convert To InterpSyn" (pprIExpr iexpr)
+ return iexpr
translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
mkConApp nm [RepI] [a1] = ConAppI nm a1
mkConApp nm [RepP] [a1] = ConAppP nm a1
mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
-mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
-mkConApp nm reps args
- = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
+mkConApp nm reps args = ConAppGen nm args
mkLam RepP RepP = LamPP
mkLam RepI RepP = LamIP
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 <- malloc (n+1);
- strncpy a ba (fromIntegral n);
- writeCharOffAddr a n '\0'
- 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"
| repOfStgExpr scrut /= RepP
-> mkCasePrim (repOfStgExpr stgexpr)
bndr (stg2expr ie scrut)
- (map doPrimAlt alts)
- (def2expr def)
+ (map (doPrimAlt ie') alts)
+ (def2expr ie' def)
+ where ie' = addOneToUniqSet ie bndr
- 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)
- (map doAlgAlt alts)
- (def2expr def)
+ (map (doAlgAlt ie') alts)
+ (def2expr ie' def)
+ where ie' = addOneToUniqSet ie bndr
StgPrimApp op args res_ty
-> mkPrimOp (repOfStgExpr stgexpr)
(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)
+ doPrimAlt ie (lit,rhs)
= AltPrim (lit2expr lit) (stg2expr ie rhs)
- doAlgAlt (dcon,vars,uses,rhs)
+ doAlgAlt ie (dcon,vars,uses,rhs)
= AltAlg (dataConTag dcon - 1)
(map id2VaaRep (toHeapOrder vars))
(stg2expr (addListToUniqSet ie vars) rhs)
in
rearranged
- def2expr StgNoDefault = Nothing
- def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
+ def2expr ie StgNoDefault = Nothing
+ def2expr ie (StgBindDefault rhs) = Just (stg2expr ie rhs)
mkAppChain ie result_rep so_far []
= panic "mkAppChain"
-- 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 ->
CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
(linkDefault ie ce dflt)
+ CaseAlgF bndr expr alts dflt ->
+ CaseAlgF bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ CaseAlgD bndr expr alts dflt ->
+ CaseAlgD bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
CasePrimP bndr expr alts dflt ->
CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
(linkDefault ie ce dflt)
CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
(linkDefault ie ce dflt)
+ CasePrimF bndr expr alts dflt ->
+ CasePrimF bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
+ CasePrimD bndr expr alts dflt ->
+ CasePrimD bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
+ (linkDefault ie ce dflt)
+
ConApp con ->
- ConApp (lookupCon ie con)
+ lookupNullaryCon ie con
ConAppI con arg0 ->
ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
ConAppPP con arg0 arg1 ->
ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
-
- ConAppPPP con arg0 arg1 arg2 ->
- ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
- (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
+ ConAppGen con args -> ConAppGen (lookupCon ie con)
+ (map (linkIExpr ie ce) args)
PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
NonRecP bind expr -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
- RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
-
NonRecI bind expr -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
+ NonRecF bind expr -> NonRecF (linkIBind ie ce bind) (linkIExpr ie ce expr)
+ NonRecD bind expr -> NonRecD (linkIBind ie ce bind) (linkIExpr ie ce expr)
+
+ RecP binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
RecI binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
+ RecF binds expr -> RecF (linkIBinds ie ce binds) (linkIExpr ie ce expr)
+ RecD binds expr -> RecD (linkIBinds ie ce binds) (linkIExpr ie ce expr)
LitI i -> LitI i
LitF i -> LitF i
VarP v -> lookupVar ce VarP v
VarI v -> lookupVar ce VarI v
+ VarF v -> lookupVar ce VarF v
+ VarD v -> lookupVar ce VarD v
LamPP bndr expr -> LamPP bndr (linkIExpr ie ce expr)
LamPI bndr expr -> LamPI bndr (linkIExpr ie ce expr)
+ LamPF bndr expr -> LamPF bndr (linkIExpr ie ce expr)
+ LamPD bndr expr -> LamPD bndr (linkIExpr ie ce expr)
LamIP bndr expr -> LamIP bndr (linkIExpr ie ce expr)
LamII bndr expr -> LamII bndr (linkIExpr ie ce expr)
+ LamIF bndr expr -> LamIF bndr (linkIExpr ie ce expr)
+ LamID bndr expr -> LamID bndr (linkIExpr ie ce expr)
+ LamFP bndr expr -> LamFP bndr (linkIExpr ie ce expr)
+ LamFI bndr expr -> LamFI bndr (linkIExpr ie ce expr)
+ LamFF bndr expr -> LamFF bndr (linkIExpr ie ce expr)
+ LamFD bndr expr -> LamFD bndr (linkIExpr ie ce expr)
+ LamDP bndr expr -> LamDP bndr (linkIExpr ie ce expr)
+ LamDI bndr expr -> LamDI bndr (linkIExpr ie ce expr)
+ LamDF bndr expr -> LamDF bndr (linkIExpr ie ce expr)
+ LamDD bndr expr -> LamDD bndr (linkIExpr ie ce expr)
AppPP fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
AppPI fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppPF fun arg -> AppPF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppPD fun arg -> AppPD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
AppIP fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
AppII fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
-
+ AppIF fun arg -> AppIF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppID fun arg -> AppID (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppFP fun arg -> AppFP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppFI fun arg -> AppFI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppFF fun arg -> AppFF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppFD fun arg -> AppFD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppDP fun arg -> AppDP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppDI fun arg -> AppDI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppDF fun arg -> AppDF (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+ AppDD fun arg -> AppDD (linkIExpr ie ce fun) (linkIExpr ie ce arg)
+
lookupCon ie con =
case lookupFM ie con of
- Just addr -> addr
+ Just (Ptr addr) -> addr
Nothing ->
-- try looking up in the object files.
case {-HACK!!!-}
Just addr -> addr
Nothing -> pprPanic "linkIExpr" (ppr con)
+-- nullary constructors don't have normal _con_info tables.
+lookupNullaryCon ie con =
+ case lookupFM ie con of
+ Just (Ptr addr) -> ConApp addr
+ Nothing ->
+ -- try looking up in the object files.
+ case {-HACK!!!-}
+ unsafePerformIO (lookupSymbol (rdrNameToCLabel con "closure")) of
+ Just (A# addr) -> Native (unsafeCoerce# addr)
+ Nothing -> pprPanic "lookupNullaryCon" (ppr con)
+
+
lookupNative ce var =
case lookupFM ce var of
Just e -> Native e
-- HACK!!! ToDo: cleaner
rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
-rdrNameToCLabel rn suffix =
+rdrNameToCLabel rn suffix
+ | isUnqual rn = pprPanic "rdrNameToCLabel" (ppr rn)
+ | otherwise =
_UNPK_(moduleNameFS (rdrNameModule rn))
++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
-- Evaluator for things of boxed (pointer) representation
-- ---------------------------------------------------------------------------
+interp :: LinkedIExpr -> HValue
+interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
+
evalP :: LinkedIExpr -> UniqFM boxed -> boxed
{-
-- always has pointer rep.
evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-evalP (AppFP e1 e2) de = unsafeCoerce# (evalF e1 de) (evalI e2 de)
-evalP (AppDP e1 e2) de = unsafeCoerce# (evalD e1 de) (evalP e2 de)
+evalP (AppFP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de)
+evalP (AppDP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-- Lambdas always return P-rep, but we need to do different things
-- depending on both the argument and result representations.
= case helper_casePrim bndr expr alts def de of
(rhs, de') -> evalP rhs de'
-{-
--- ConApp can only be handled by evalP
-evalP (ConApp itbl args) se de
- = loop args
- where
- -- This appalling hack suggested (gleefully) by SDM
- -- It is not well typed (needless to say?)
- loop :: [Expr] -> boxed
- loop []
- = trace "loop-empty" (
- case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
- )
- loop (a:as)
- = trace "loop-not-empty" (
- case repOf a of
- RepI -> case evalI a de of i# -> loop as i#
- RepP -> let p = evalP a de in loop as p
- )
--}
+evalP (ConApp (A# itbl)) de
+ = mci_make_constr0 itbl
evalP (ConAppI (A# itbl) a1) de
= case evalI a1 de of i1 -> mci_make_constrI itbl i1
-evalP (ConApp (A# itbl)) de
- = mci_make_constr itbl
-
evalP (ConAppP (A# itbl) a1) de
- = let p1 = evalP a1 de
- in mci_make_constrP itbl p1
+ = evalP (ConAppGen (A# itbl) [a1]) de
+-- = let p1 = evalP a1 de
+-- in mci_make_constrP itbl p1
evalP (ConAppPP (A# itbl) a1 a2) de
= let p1 = evalP a1 de
p2 = evalP a2 de
in mci_make_constrPP itbl p1 p2
-evalP (ConAppPPP (A# itbl) a1 a2 a3) de
- = let p1 = evalP a1 de
- p2 = evalP a2 de
- p3 = evalP a3 de
- in mci_make_constrPPP itbl p1 p2 p3
-
-
+evalP (ConAppGen itbl args) de
+ = loop args
+ where
+ -- This appalling hack suggested (gleefully) by SDM
+ -- It is not well typed (needless to say?)
+ loop :: [LinkedIExpr] -> boxed
+ loop []
+ = case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
+ loop (a:as)
+ = case repOf a of
+ RepP -> let p = evalP a de in loop as p
+ RepI -> case evalI a de of i# -> loop as i#
+ RepF -> case evalF a de of f# -> loop as f#
+ RepD -> case evalD a de of d# -> loop as d#
evalP other de
= error ("evalP: unhandled case: " ++ showExprTag other)
-- 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 (VarP _) = RepI
+repOf (Native _) = RepP
+
+repOf (VarP _) = RepP
repOf (VarI _) = RepI
repOf (VarF _) = RepF
repOf (VarD _) = RepD
repOf (ConAppI _ _) = RepP
repOf (ConAppP _ _) = RepP
repOf (ConAppPP _ _ _) = RepP
-repOf (ConAppPPP _ _ _ _) = RepP
+repOf (ConAppGen _ _) = RepP
repOf (CaseAlgP _ _ _ _) = RepP
repOf (CaseAlgI _ _ _ _) = RepI
-> (LinkedIExpr, UniqFM boxed)
helper_casePrim bndr expr alts def de
= case repOf expr of
- -- Umm, can expr have any other rep? Yes ...
- -- CharRep, DoubleRep, FloatRep. What about string reps?
RepI -> case evalI expr de of
i# -> (select_altPrim alts def (LitI i#),
addToUFM de bndr (unsafeCoerce# (I# i#)))
+ RepF -> case evalF expr de of
+ f# -> (select_altPrim alts def (LitF f#),
+ addToUFM de bndr (unsafeCoerce# (F# f#)))
+ RepD -> case evalD expr de of
+ d# -> (select_altPrim alts def (LitD d#),
+ addToUFM de bndr (unsafeCoerce# (D# d#)))
augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
= case rep of
RepP -> indexPtrOffClosure con offset
RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
+ RepF -> unsafeCoerce# (F# (indexFloatOffClosure con offset))
+ RepD -> unsafeCoerce# (D# (indexDoubleOffClosure con offset))
in
augment_from_constr (addToUFM de v v_binding) con
(vs,offset + repSizeW rep)
indexIntOffClosure con (I# offset)
= case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
+indexFloatOffClosure :: a -> Int -> Float#
+indexFloatOffClosure con (I# offset)
+ = unsafeCoerce# (indexWordOffClosure# con offset) -- eek!
------------------------------------------------------------------------
--- Manufacturing of info tables for DataCons defined in this module ---
------------------------------------------------------------------------
+#if __GLASGOW_HASKELL__ <= 408
+type ItblPtr = Addr
+#else
+type ItblPtr = Ptr StgInfoTable
+#endif
+
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
mkITbls [] = return emptyFM
mk_dirret_itbl (dcon, conNo)
= mk_itbl dcon conNo mci_constr_entry
- mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,Addr)
+ mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
mk_itbl dcon conNo entry_addr
= let (tot_wds, ptr_wds, _)
= mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
entry_addr_w :: Word32
entry_addr_w = fromIntegral (addrToInt entry_addr)
in
- do addr <- mallocElem itbl
+ do addr <- malloc
putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
putStrLn ("# ptrs of itbl is " ++ show ptrs)
putStrLn ("# nptrs of itbl is " ++ show nptrs)
poke addr itbl
- return (toRdrName dcon, intToAddr (addrToInt addr + 8))
+ return (toRdrName dcon, addr `plusPtr` 8)
byte :: Int -> Word32 -> Word32
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
fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
poke a0 itbl
- = do a1 <- store (ptrs itbl) a0
+ = do a1 <- store (ptrs itbl) (castPtr a0)
a2 <- store (nptrs itbl) a1
a3 <- store (tipe itbl) a2
a4 <- store (srtlen itbl) a3
return ()
peek a0
- = do (a1,ptrs) <- load a0
+ = do (a1,ptrs) <- load (castPtr a0)
(a2,nptrs) <- load a1
(a3,tipe) <- load a2
(a4,srtlen) <- load a3
fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldAl sel x = alignment (sel x)
-store :: Storable a => a -> Addr -> IO Addr
+store :: Storable a => a -> Ptr a -> IO (Ptr b)
store x addr = do poke addr x
- return (addr `plusAddr` fromIntegral (sizeOf x))
+ return (castPtr (addr `plusPtr` sizeOf x))
-load :: Storable a => Addr -> IO (Addr, a)
+load :: Storable a => Ptr a -> IO (Ptr b, a)
load addr = do x <- peek addr
- return (addr `plusAddr` fromIntegral (sizeOf x), x)
+ return (castPtr (addr `plusPtr` sizeOf x), x)
-----------------------------------------------------------------------------q
-foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
-
-#endif /* #if __GLASGOW_HASKELL__ <= 408 */
+foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
\end{code}
projects / ghc-hetmet.git / blobdiff