% % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000 % \section[StgInterp]{Translates STG syntax to interpretable form, and run it} \begin{code} module StgInterp ( ClosureEnv, ItblEnv, filterNameMap, -- :: [ModuleName] -> FiniteMap Name a -- -> FiniteMap Name 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 {- ----------------------------------------------------------------------------- ToDo: - link should be in the IO monad, so it can modify the symtabs as it goes along - need a way to remove the bindings for a module from the symtabs. maybe the symtabs should be indexed by module first. - change the representation to something less verbose (?). - converting string literals to Addr# is horrible and introduces a memory leak. See if something can be done about this. - lots of assumptions about word size vs. double size etc. ----------------------------------------------------------------------------- -} #include "HsVersions.h" import Linker import Id ( Id, idPrimRep ) import Outputable import Var import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Literal ( Literal(..) ) import Type ( Type, typePrimRep, deNoteType, repType, funResultTy ) import DataCon ( DataCon, dataConTag, dataConRepArgTys ) import ClosureInfo ( mkVirtHeapOffsets ) import Module ( ModuleName, moduleName ) import RdrName import Name hiding (filterNameEnv) import Util import UniqFM import UniqSet --import {-# SOURCE #-} MCI_make_constr import FastString import GlaExts ( Int(..) ) import Module ( moduleNameFS ) import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize ) import Class ( Class, classTyCon ) import InterpSyn import StgSyn import FiniteMap import OccName ( occNameString ) import ErrUtils ( showPass, dumpIfSet_dyn ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import Panic ( panic ) import IOExts import Addr import Bits import Foreign import CTypes import IO import PrelGHC --( unsafeCoerce#, dataToTag#, -- indexPtrOffClosure#, indexWordOffClosure# ) import PrelAddr ( Addr(..) ) import PrelFloat ( Float(..), Double(..) ) #if 1 interp = panic "interp" stgExprToInterpSyn = panic "stgExprToInterpSyn" stgBindsToInterpSyn = panic "stgBindsToInterpSyn" iExprToHValue = panic "iExprToHValue" linkIModules = panic "linkIModules" filterNameMap = panic "filterNameMap" type ItblEnv = FiniteMap Name (Ptr StgInfoTable) type ClosureEnv = FiniteMap Name HValue data StgInfoTable = StgInfoTable { ptrs :: Word16, nptrs :: Word16, srtlen :: Word16, tipe :: Word16, code0, code1, code2, code3, code4, code5, code6, code7 :: Word8 } #else -- --------------------------------------------------------------------------- -- Environments needed by the linker -- --------------------------------------------------------------------------- type ItblEnv = FiniteMap Name (Ptr StgInfoTable) type ClosureEnv = FiniteMap Name HValue emptyClosureEnv = emptyFM -- remove all entries for a given set of modules from the environment filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a filterNameMap mods env = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env -- --------------------------------------------------------------------------- -- Turn an UnlinkedIExpr into a value we can run, for the interpreter -- --------------------------------------------------------------------------- iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue iExprToHValue ie ce expr = do linked_expr <- linkIExpr ie ce expr return (interp linked_expr) -- --------------------------------------------------------------------------- -- Convert STG to an unlinked interpretable -- --------------------------------------------------------------------------- -- visible from outside 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)] translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es] where ie' = addListToUniqSet ie (map fst vs_n_es) isRec (StgNonRec _ _) = False isRec (StgRec _) = True rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs) = mkLambdas args where rhsExpr = stg2expr (addListToUniqSet ie args) rhs rhsRep = repOfStgExpr rhs mkLambdas [] = rhsExpr mkLambdas [v] = mkLam (repOfId v) rhsRep v rhsExpr mkLambdas (v:vs) = mkLam (repOfId v) RepP v (mkLambdas vs) rhs2expr ie (StgRhsCon ccs dcon args) = conapp2expr ie dcon args conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr conapp2expr ie dcon args = mkConApp con_rdrname reps exprs where con_rdrname = getName dcon exprs = map (arg2expr ie) inHeapOrder reps = map repOfArg inHeapOrder inHeapOrder = toHeapOrder args toHeapOrder :: [StgArg] -> [StgArg] toHeapOrder args = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args (rearranged, offsets) = unzip rearranged_w_offsets in rearranged -- Handle most common cases specially; do the rest with a generic -- mechanism (deferred till later :) mkConApp :: Name -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr mkConApp nm [] [] = ConApp nm 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 reps args = ConAppGen nm args mkLam RepP RepP = LamPP mkLam RepI RepP = LamIP mkLam RepP RepI = LamPI mkLam RepI RepI = LamII mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr) mkApp RepP RepP = AppPP mkApp RepI RepP = AppIP mkApp RepP RepI = AppPI mkApp RepI RepI = AppII mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr) repOfId :: Id -> Rep repOfId = primRep2Rep . idPrimRep primRep2Rep primRep = case primRep of -- genuine lifted types PtrRep -> RepP -- all these are unboxed, fit into a word, and we assume they -- all have the same call/return convention. IntRep -> RepI CharRep -> RepI WordRep -> RepI AddrRep -> RepI WeakPtrRep -> RepI StablePtrRep -> RepI -- these are pretty dodgy: really pointers, but -- we can't let the compiler build thunks with these reps. ForeignObjRep -> RepP StableNameRep -> RepP ThreadIdRep -> RepP ArrayRep -> RepP ByteArrayRep -> RepP FloatRep -> RepF DoubleRep -> RepD other -> pprPanic "primRep2Rep" (ppr other) repOfStgExpr :: StgExpr -> Rep repOfStgExpr stgexpr = case stgexpr of StgLit lit -> repOfLit lit StgCase scrut live liveR bndr srt alts -> case altRhss alts of (a:_) -> repOfStgExpr a [] -> panic "repOfStgExpr: no alts" StgApp var [] -> repOfId var StgApp var args -> repOfApp ((deNoteType.repType.idType) var) (length args) StgPrimApp op args res_ty -> (primRep2Rep.typePrimRep) res_ty StgLet binds body -> repOfStgExpr body StgLetNoEscape live liveR binds body -> repOfStgExpr body StgConApp con args -> RepP -- by definition other -> pprPanic "repOfStgExpr" (ppr other) where altRhss (StgAlgAlts tycon alts def) = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def altRhss (StgPrimAlts tycon alts def) = [rhs | (lit,rhs) <- alts] ++ defRhs def defRhs StgNoDefault = [] defRhs (StgBindDefault rhs) = [rhs] -- returns the Rep of the result of applying ty to n args. repOfApp :: Type -> Int -> Rep repOfApp ty 0 = (primRep2Rep.typePrimRep) ty repOfApp ty n = repOfApp (funResultTy ty) (n-1) repOfLit lit = case lit of MachInt _ -> RepI MachWord _ -> RepI MachAddr _ -> RepI MachChar _ -> RepI MachFloat _ -> RepF MachDouble _ -> RepD MachStr _ -> RepI -- because it's a ptr outside the heap other -> pprPanic "repOfLit" (ppr lit) lit2expr :: Literal -> UnlinkedIExpr lit2expr lit = case lit of MachInt i -> case fromIntegral i of I# i -> LitI i MachWord i -> case fromIntegral i of I# i -> LitI i MachAddr i -> case fromIntegral i of I# i -> LitI i MachChar i -> case fromIntegral i of I# i -> LitI i MachFloat f -> case fromRational f of F# f -> LitF f MachDouble f -> case fromRational f of D# f -> LitD f MachStr s -> case s of CharStr s i -> LitI (addr2Int# s) FastString _ l ba -> -- sigh, a string in the heap is no good to us. We need a -- static C pointer, since the type of a string literal is -- Addr#. So, copy the string into C land and introduce a -- memory leak at the same time. let n = I# l in -- 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" other -> pprPanic "lit2expr" (ppr lit) stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr stg2expr ie stgexpr = case stgexpr of StgApp var [] -> mkVar ie (repOfId var) var StgApp var args -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args StgLit lit -> lit2expr lit StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def) | repOfStgExpr scrut /= RepP -> mkCasePrim (repOfStgExpr stgexpr) bndr (stg2expr ie scrut) (map (doPrimAlt ie') alts) (def2expr ie' def) | otherwise -> pprPanic "stg2expr(StgCase,prim)" (ppr (repOfStgExpr scrut) $$ (case scrut of (StgApp v _) -> ppr v <+> ppr (idType v) <+> ppr (idPrimRep v)) $$ ppr stgexpr) where ie' = addOneToUniqSet ie bndr StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def) | repOfStgExpr scrut == RepP -> mkCaseAlg (repOfStgExpr stgexpr) bndr (stg2expr ie scrut) (map (doAlgAlt ie') alts) (def2expr ie' def) where ie' = addOneToUniqSet ie bndr StgPrimApp op args res_ty -> mkPrimOp (repOfStgExpr stgexpr) op (map (arg2expr ie) args) StgConApp dcon args -> conapp2expr ie dcon args StgLet binds@(StgNonRec v e) body -> mkNonRec (repOfStgExpr stgexpr) (head (translateBind ie binds)) (stg2expr (addOneToUniqSet ie v) body) StgLet binds@(StgRec bs) body -> mkRec (repOfStgExpr stgexpr) (translateBind ie binds) (stg2expr (addListToUniqSet ie (map fst bs)) body) -- treat let-no-escape just like let. StgLetNoEscape _ _ binds body -> stg2expr ie (StgLet binds body) other -> pprPanic "stg2expr" (ppr stgexpr) where doPrimAlt ie (lit,rhs) = AltPrim (lit2expr lit) (stg2expr ie rhs) doAlgAlt ie (dcon,vars,uses,rhs) = AltAlg (dataConTag dcon - 1) (map id2VaaRep (toHeapOrder vars)) (stg2expr (addListToUniqSet ie vars) rhs) toHeapOrder vars = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars (rearranged,offsets) = unzip rearranged_w_offsets in rearranged def2expr ie StgNoDefault = Nothing def2expr ie (StgBindDefault rhs) = Just (stg2expr ie rhs) mkAppChain ie result_rep so_far [] = panic "mkAppChain" mkAppChain ie result_rep so_far [a] = mkApp (repOfArg a) result_rep so_far (arg2expr ie a) mkAppChain ie result_rep so_far (a:as) = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as mkCasePrim RepI = CasePrimI mkCasePrim RepP = CasePrimP mkCaseAlg RepI = CaseAlgI mkCaseAlg RepP = CaseAlgP -- any var that isn't in scope is turned into a Native mkVar ie rep var | var `elementOfUniqSet` ie = (case rep of RepI -> VarI RepF -> VarF RepD -> VarD RepP -> VarP) var | otherwise = Native (getName var) mkRec RepI = RecI mkRec RepP = RecP mkNonRec RepI = NonRecI mkNonRec RepP = NonRecP mkPrimOp RepI = PrimOpI mkPrimOp RepP = PrimOpP arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v arg2expr ie (StgLitArg lit) = lit2expr lit arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty) repOfArg :: StgArg -> Rep repOfArg (StgVarArg v) = repOfId v repOfArg (StgLitArg lit) = repOfLit lit repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty) id2VaaRep var = (var, repOfId var) -- --------------------------------------------------------------------------- -- Link interpretables into something we can run -- --------------------------------------------------------------------------- GLOBAL_VAR(cafTable, [], [HValue]) addCAF :: HValue -> IO () addCAF x = do xs <- readIORef cafTable; writeIORef cafTable (x:xs) linkIModules :: ItblEnv -- incoming global itbl env; returned updated -> ClosureEnv -- incoming global closure env; returned updated -> [([UnlinkedIBind], ItblEnv)] -> IO ([LinkedIBind], ItblEnv, ClosureEnv) linkIModules gie gce mods = do let (bindss, ies) = unzip mods binds = concat bindss top_level_binders = map (getName.binder) binds final_gie = foldr plusFM gie ies (new_binds, new_gce) <- fixIO (\ ~(new_binds, new_gce) -> do new_binds <- linkIBinds final_gie new_gce binds let new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds let new_gce = addListToFM gce (zip top_level_binders new_rhss) return (new_binds, new_gce)) return (new_binds, final_gie, new_gce) -- We're supposed to augment the environments with the values of any -- external functions/info tables we need as we go along, but that's a -- lot of hassle so for now I'll look up external things as they crop -- up and not cache them in the source symbol tables. The interpreted -- code will still be referenced in the source symbol tables. linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> IO [LinkedIBind] linkIBinds ie ce binds = mapM (linkIBind ie ce) binds linkIBind ie ce (IBind bndr expr) = do expr <- linkIExpr ie ce expr return (IBind bndr expr) linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO LinkedIExpr linkIExpr ie ce expr = case expr of CaseAlgP bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgP CaseAlgI bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgI CaseAlgF bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgF CaseAlgD bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgD CasePrimP bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimP CasePrimI bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimI CasePrimF bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimF CasePrimD bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimD ConApp con -> lookupNullaryCon ie con ConAppI con arg0 -> do con' <- lookupCon ie con arg' <- linkIExpr ie ce arg0 return (ConAppI con' arg') ConAppP con arg0 -> do con' <- lookupCon ie con arg' <- linkIExpr ie ce arg0 return (ConAppP con' arg') ConAppPP con arg0 arg1 -> do con' <- lookupCon ie con arg0' <- linkIExpr ie ce arg0 arg1' <- linkIExpr ie ce arg1 return (ConAppPP con' arg0' arg1') ConAppGen con args -> do con <- lookupCon ie con args <- mapM (linkIExpr ie ce) args return (ConAppGen con args) PrimOpI op args -> linkPrimOp ie ce PrimOpI op args PrimOpP op args -> linkPrimOp ie ce PrimOpP op args NonRecP bind expr -> linkNonRec ie ce NonRecP bind expr NonRecI bind expr -> linkNonRec ie ce NonRecI bind expr NonRecF bind expr -> linkNonRec ie ce NonRecF bind expr NonRecD bind expr -> linkNonRec ie ce NonRecD bind expr RecP binds expr -> linkRec ie ce RecP binds expr RecI binds expr -> linkRec ie ce RecI binds expr RecF binds expr -> linkRec ie ce RecF binds expr RecD binds expr -> linkRec ie ce RecD binds expr LitI i -> return (LitI i) LitF i -> return (LitF i) LitD i -> return (LitD i) Native var -> lookupNative ce var 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 -> linkLam ie ce LamPP bndr expr LamPI bndr expr -> linkLam ie ce LamPI bndr expr LamPF bndr expr -> linkLam ie ce LamPF bndr expr LamPD bndr expr -> linkLam ie ce LamPD bndr expr LamIP bndr expr -> linkLam ie ce LamIP bndr expr LamII bndr expr -> linkLam ie ce LamII bndr expr LamIF bndr expr -> linkLam ie ce LamIF bndr expr LamID bndr expr -> linkLam ie ce LamID bndr expr LamFP bndr expr -> linkLam ie ce LamFP bndr expr LamFI bndr expr -> linkLam ie ce LamFI bndr expr LamFF bndr expr -> linkLam ie ce LamFF bndr expr LamFD bndr expr -> linkLam ie ce LamFD bndr expr LamDP bndr expr -> linkLam ie ce LamDP bndr expr LamDI bndr expr -> linkLam ie ce LamDI bndr expr LamDF bndr expr -> linkLam ie ce LamDF bndr expr LamDD bndr expr -> linkLam ie ce LamDD bndr expr AppPP fun arg -> linkApp ie ce AppPP fun arg AppPI fun arg -> linkApp ie ce AppPI fun arg AppPF fun arg -> linkApp ie ce AppPF fun arg AppPD fun arg -> linkApp ie ce AppPD fun arg AppIP fun arg -> linkApp ie ce AppIP fun arg AppII fun arg -> linkApp ie ce AppII fun arg AppIF fun arg -> linkApp ie ce AppIF fun arg AppID fun arg -> linkApp ie ce AppID fun arg AppFP fun arg -> linkApp ie ce AppFP fun arg AppFI fun arg -> linkApp ie ce AppFI fun arg AppFF fun arg -> linkApp ie ce AppFF fun arg AppFD fun arg -> linkApp ie ce AppFD fun arg AppDP fun arg -> linkApp ie ce AppDP fun arg AppDI fun arg -> linkApp ie ce AppDI fun arg AppDF fun arg -> linkApp ie ce AppDF fun arg AppDD fun arg -> linkApp ie ce AppDD fun arg linkAlgCase ie ce bndr expr alts dflt con = do expr <- linkIExpr ie ce expr alts <- mapM (linkAlgAlt ie ce) alts dflt <- linkDefault ie ce dflt return (con bndr expr alts dflt) linkPrimCase ie ce bndr expr alts dflt con = do expr <- linkIExpr ie ce expr alts <- mapM (linkPrimAlt ie ce) alts dflt <- linkDefault ie ce dflt return (con bndr expr alts dflt) linkAlgAlt ie ce (AltAlg tag args rhs) = do rhs <- linkIExpr ie ce rhs return (AltAlg tag args rhs) linkPrimAlt ie ce (AltPrim lit rhs) = do rhs <- linkIExpr ie ce rhs lit <- linkIExpr ie ce lit return (AltPrim lit rhs) linkDefault ie ce Nothing = return Nothing linkDefault ie ce (Just expr) = do expr <- linkIExpr ie ce expr return (Just expr) linkNonRec ie ce con bind expr = do expr <- linkIExpr ie ce expr bind <- linkIBind ie ce bind return (con bind expr) linkRec ie ce con binds expr = do expr <- linkIExpr ie ce expr binds <- linkIBinds ie ce binds return (con binds expr) linkLam ie ce con bndr expr = do expr <- linkIExpr ie ce expr return (con bndr expr) linkApp ie ce con fun arg = do fun <- linkIExpr ie ce fun arg <- linkIExpr ie ce arg return (con fun arg) linkPrimOp ie ce con op args = do args <- mapM (linkIExpr ie ce) args return (con op args) lookupCon ie con = case lookupFM ie con of Just (Ptr addr) -> return addr Nothing -> do -- try looking up in the object files. m <- lookupSymbol (nameToCLabel con "con_info") case m of Just addr -> return 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) -> return (ConApp addr) Nothing -> do -- try looking up in the object files. m <- lookupSymbol (nameToCLabel con "closure") case m of Just (A# addr) -> return (Native (unsafeCoerce# addr)) Nothing -> pprPanic "lookupNullaryCon" (ppr con) lookupNative ce var = unsafeInterleaveIO (do case lookupFM ce var of Just e -> return (Native e) Nothing -> do -- try looking up in the object files. let lbl = (nameToCLabel var "closure") m <- lookupSymbol lbl case m of Just (A# addr) -> do addCAF (unsafeCoerce# addr) return (Native (unsafeCoerce# addr)) Nothing -> pprPanic "linkIExpr" (ppr var) ) -- some VarI/VarP refer to top-level interpreted functions; we change -- them into Natives here. lookupVar ce f v = unsafeInterleaveIO ( case lookupFM ce (getName v) of Nothing -> return (f v) Just e -> return (Native e) ) -- HACK!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix = _UNPK_(moduleNameFS (rdrNameModule rn)) ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix where rn = toRdrName n -- --------------------------------------------------------------------------- -- The interpreter proper -- --------------------------------------------------------------------------- -- The dynamic environment contains everything boxed. -- eval* functions which look up values in it will know the -- representation of the thing they are looking up, so they -- can cast/unbox it as necessary. -- --------------------------------------------------------------------------- -- Evaluator for things of boxed (pointer) representation -- --------------------------------------------------------------------------- interp :: LinkedIExpr -> HValue interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM) evalP :: LinkedIExpr -> UniqFM boxed -> boxed {- evalP expr de -- | trace ("evalP: " ++ showExprTag expr) False | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False = error "evalP: ?!?!" -} evalP (Native p) de = unsafeCoerce# p -- First try the dynamic env. If that fails, assume it's a top-level -- binding and look in the static env. That gives an Expr, which we -- must convert to a boxed thingy by applying evalP to it. Because -- top-level bindings are always ptr-rep'd (either lambdas or boxed -- CAFs), it's always safe to use evalP. evalP (VarP v) de = case lookupUFM de v of Just xx -> xx Nothing -> error ("evalP: lookupUFM " ++ show v) -- Deal with application of a function returning a pointer rep -- to arguments of any persuasion. Note that the function itself -- 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# (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. evalP (LamPP x b) de = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP)) evalP (LamPI x b) de = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP)) evalP (LamPF x b) de = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP)) evalP (LamPD x b) de = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP)) evalP (LamIP x b) de = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI)))) evalP (LamII x b) de = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI)))) evalP (LamIF x b) de = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI)))) evalP (LamID x b) de = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI)))) evalP (LamFP x b) de = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI)))) evalP (LamFI x b) de = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI)))) evalP (LamFF x b) de = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI)))) evalP (LamFD x b) de = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI)))) evalP (LamDP x b) de = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI)))) evalP (LamDI x b) de = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI)))) evalP (LamDF x b) de = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI)))) evalP (LamDD x b) de = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI)))) -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, -- except in the sense that we go on and evaluate the body with whichever -- evaluator was used for the expression as a whole. evalP (NonRecP bind e) de = evalP e (augment_nonrec bind de) evalP (RecP binds b) de = evalP b (augment_rec binds de) evalP (CaseAlgP bndr expr alts def) de = case helper_caseAlg bndr expr alts def de of (rhs, de') -> evalP rhs de' evalP (CasePrimP bndr expr alts def) de = case helper_casePrim bndr expr alts def de of (rhs, de') -> evalP rhs de' 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 (ConAppP (A# itbl) a1) de = 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 (ConAppGen itbl args) de = let c = case itbl of A# a# -> mci_make_constr a# in c `seq` loop c 1#{-leave room for hdr-} args where loop :: a{-closure-} -> Int# -> [LinkedIExpr] -> a loop c off [] = c loop c off (a:as) = case repOf a of RepP -> let c' = setPtrOffClosure c off (evalP a de) in c' `seq` loop c' (off +# 1#) as RepI -> case evalI a de of { i# -> let c' = setIntOffClosure c off i# in c' `seq` loop c' (off +# 1#) as } RepF -> case evalF a de of { f# -> let c' = setFloatOffClosure c off f# in c' `seq` loop c' (off +# 1#) as } RepD -> case evalD a de of { d# -> let c' = setDoubleOffClosure c off d# in c' `seq` loop c' (off +# 2#) as } evalP (PrimOpP IntEqOp [e1,e2]) de = case evalI e1 de of i1# -> case evalI e2 de of i2# -> unsafeCoerce# (i1# ==# i2#) evalP (PrimOpP primop _) de = error ("evalP: unhandled primop: " ++ showSDoc (ppr primop)) evalP other de = error ("evalP: unhandled case: " ++ showExprTag other) -------------------------------------------------------- --- Evaluator for things of Int# representation -------------------------------------------------------- -- 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# evalI (VarI v) de = case lookupUFM de v of Just e -> case unsafeCoerce# e of I# i -> i Nothing -> error ("evalI: lookupUFM " ++ show v) -- Deal with application of a function returning an Int# rep -- to arguments of any persuasion. Note that the function itself -- always has pointer rep. evalI (AppII e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de) evalI (AppPI e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de) evalI (AppFI e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de) evalI (AppDI e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de) -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, -- except in the sense that we go on and evaluate the body with whichever -- evaluator was used for the expression as a whole. evalI (NonRecI bind b) de = evalI b (augment_nonrec bind de) evalI (RecI binds b) de = evalI b (augment_rec binds de) evalI (CaseAlgI bndr expr alts def) de = case helper_caseAlg bndr expr alts def de of (rhs, de') -> evalI rhs de' evalI (CasePrimI bndr expr alts def) de = case helper_casePrim bndr expr alts def de of (rhs, de') -> evalI rhs de' -- evalI can't be applied to a lambda term, by defn, since those -- are ptr-rep'd. evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de evalI (PrimOpI DataToTagOp [e1]) de = dataToTag# (evalP e1 de) evalI (PrimOpI primop _) de = error ("evalI: unhandled primop: " ++ showSDoc (ppr primop)) --evalI (NonRec (IBind v e) b) de -- = evalI b (augment de v (eval e de)) evalI other de = error ("evalI: unhandled case: " ++ showExprTag other) -------------------------------------------------------- --- Evaluator for things of Float# representation -------------------------------------------------------- -- 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# evalF (VarF v) de = case lookupUFM de v of Just e -> case unsafeCoerce# e of F# i -> i Nothing -> error ("evalF: lookupUFM " ++ show v) -- Deal with application of a function returning an Int# rep -- to arguments of any persuasion. Note that the function itself -- always has pointer rep. evalF (AppIF e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de) evalF (AppPF e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de) evalF (AppFF e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de) evalF (AppDF e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de) -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, -- except in the sense that we go on and evaluate the body with whichever -- evaluator was used for the expression as a whole. evalF (NonRecF bind b) de = evalF b (augment_nonrec bind de) evalF (RecF binds b) de = evalF b (augment_rec binds de) evalF (CaseAlgF bndr expr alts def) de = case helper_caseAlg bndr expr alts def de of (rhs, de') -> evalF rhs de' evalF (CasePrimF bndr expr alts def) de = case helper_casePrim bndr expr alts def de of (rhs, de') -> evalF rhs de' -- evalF can't be applied to a lambda term, by defn, since those -- are ptr-rep'd. evalF (PrimOpF op _) de = error ("evalF: unhandled primop: " ++ showSDoc (ppr op)) evalF other de = error ("evalF: unhandled case: " ++ showExprTag other) -------------------------------------------------------- --- Evaluator for things of Double# representation -------------------------------------------------------- -- 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# evalD (VarD v) de = case lookupUFM de v of Just e -> case unsafeCoerce# e of D# i -> i Nothing -> error ("evalD: lookupUFM " ++ show v) -- Deal with application of a function returning an Int# rep -- to arguments of any persuasion. Note that the function itself -- always has pointer rep. evalD (AppID e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de) evalD (AppPD e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de) evalD (AppFD e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de) evalD (AppDD e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de) -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps, -- except in the sense that we go on and evaluate the body with whichever -- evaluator was used for the expression as a whole. evalD (NonRecD bind b) de = evalD b (augment_nonrec bind de) evalD (RecD binds b) de = evalD b (augment_rec binds de) evalD (CaseAlgD bndr expr alts def) de = case helper_caseAlg bndr expr alts def de of (rhs, de') -> evalD rhs de' evalD (CasePrimD bndr expr alts def) de = case helper_casePrim bndr expr alts def de of (rhs, de') -> evalD rhs de' -- evalD can't be applied to a lambda term, by defn, since those -- are ptr-rep'd. evalD (PrimOpD op _) de = error ("evalD: unhandled primop: " ++ showSDoc (ppr op)) evalD other de = error ("evalD: unhandled case: " ++ showExprTag other) -------------------------------------------------------- --- Helper bits and pieces -------------------------------------------------------- -- Find the Rep of any Expr repOf :: LinkedIExpr -> Rep repOf (LamPP _ _) = RepP repOf (LamPI _ _) = RepP repOf (LamPF _ _) = RepP repOf (LamPD _ _) = RepP repOf (LamIP _ _) = RepP repOf (LamII _ _) = RepP repOf (LamIF _ _) = RepP repOf (LamID _ _) = RepP repOf (LamFP _ _) = RepP repOf (LamFI _ _) = RepP repOf (LamFF _ _) = RepP repOf (LamFD _ _) = RepP repOf (LamDP _ _) = RepP repOf (LamDI _ _) = RepP repOf (LamDF _ _) = RepP repOf (LamDD _ _) = RepP repOf (AppPP _ _) = RepP repOf (AppPI _ _) = RepI repOf (AppPF _ _) = RepF repOf (AppPD _ _) = RepD repOf (AppIP _ _) = RepP repOf (AppII _ _) = RepI repOf (AppIF _ _) = RepF repOf (AppID _ _) = RepD repOf (AppFP _ _) = RepP repOf (AppFI _ _) = RepI repOf (AppFF _ _) = RepF repOf (AppFD _ _) = RepD repOf (AppDP _ _) = RepP repOf (AppDI _ _) = RepI repOf (AppDF _ _) = RepF repOf (AppDD _ _) = RepD repOf (NonRecP _ _) = RepP repOf (NonRecI _ _) = RepI 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 _) = RepP repOf (VarI _) = RepI repOf (VarF _) = RepF repOf (VarD _) = RepD repOf (PrimOpP _ _) = RepP repOf (PrimOpI _ _) = RepI repOf (PrimOpF _ _) = RepF repOf (PrimOpD _ _) = RepD repOf (ConApp _) = RepP repOf (ConAppI _ _) = RepP repOf (ConAppP _ _) = RepP repOf (ConAppPP _ _ _) = RepP repOf (ConAppGen _ _) = RepP repOf (CaseAlgP _ _ _ _) = RepP repOf (CaseAlgI _ _ _ _) = RepI repOf (CaseAlgF _ _ _ _) = RepF repOf (CaseAlgD _ _ _ _) = RepD repOf (CasePrimP _ _ _ _) = RepP repOf (CasePrimI _ _ _ _) = RepI repOf (CasePrimF _ _ _ _) = RepF repOf (CasePrimD _ _ _ _) = RepD repOf other = error ("repOf: unhandled case: " ++ showExprTag other) -- how big (in words) is one of these repSizeW :: Rep -> Int repSizeW RepI = 1 repSizeW RepP = 1 -- Evaluate an expression, using the appropriate evaluator, -- then box up the result. Note that it's only safe to use this -- to create values to put in the environment. You can't use it -- to create a value which might get passed to native code since that -- code will have no idea that unboxed things have been boxed. eval :: LinkedIExpr -> UniqFM boxed -> boxed eval expr de = case repOf expr of RepI -> unsafeCoerce# (I# (evalI expr de)) RepP -> evalP expr de RepF -> unsafeCoerce# (F# (evalF expr de)) RepD -> unsafeCoerce# (D# (evalD expr de)) -- Evaluate the scrutinee of a case, select an alternative, -- augment the environment appropriately, and return the alt -- and the augmented environment. helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr -> UniqFM boxed -> (LinkedIExpr, UniqFM boxed) helper_caseAlg bndr expr alts def de = let exprEv = evalP expr de in exprEv `seq` -- vitally important; otherwise exprEv is never eval'd case select_altAlg (tagOf exprEv) alts def of (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv) exprEv (vars,1)) helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr -> UniqFM boxed -> (LinkedIExpr, UniqFM boxed) helper_casePrim bndr expr alts def de = case repOf expr of 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 augment_from_constr de con ([],offset) = de augment_from_constr de con ((v,rep):vs,offset) = let v_binding = 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) -- Augment the environment for a non-recursive let. augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed augment_nonrec (IBind v e) de = addToUFM de v (eval e de) -- Augment the environment for a recursive let. augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed augment_rec binds de = let vars = map binder binds rhss = map bindee binds rhs_vs = map (\rhs -> eval rhs de') rhss de' = addListToUFM de (zip vars rhs_vs) in de' -- a must be a constructor? tagOf :: a -> Int tagOf x = I# (dataToTag# x) select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr) select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!" select_altAlg tag [] (Just def) = ([],def) select_altAlg tag ((AltAlg tagNo vars rhs):alts) def = if tag == tagNo then (vars,rhs) else select_altAlg tag alts def -- literal may only be a literal, not an arbitrary expression select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!" select_altPrim [] (Just def) literal = def select_altPrim ((AltPrim lit rhs):alts) def literal = if eqLits lit literal then rhs else select_altPrim alts def literal eqLits (LitI i1#) (LitI i2#) = i1# ==# i2# -- ---------------------------------------------------------------------- -- Grotty inspection and creation of closures -- ---------------------------------------------------------------------- -- a is a constructor indexPtrOffClosure :: a -> Int -> b indexPtrOffClosure con (I# offset) = case indexPtrOffClosure# con offset of (# x #) -> x indexIntOffClosure :: a -> Int -> Int# 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) -- TOCK TOCK TOCK! Those GHC developers are crazy. indexDoubleOffClosure :: a -> Int -> Double# indexDoubleOffClosure con (I# offset) = unsafeCoerce# (panic "indexDoubleOffClosure") setPtrOffClosure :: a -> Int# -> b -> a setPtrOffClosure a i b = case setPtrOffClosure# a i b of (# c #) -> c setIntOffClosure :: a -> Int# -> Int# -> a setIntOffClosure a i b = case setWordOffClosure# a i (int2Word# b) of (# c #) -> c setFloatOffClosure :: a -> Int# -> Float# -> a setFloatOffClosure a i b = case setWordOffClosure# a i (unsafeCoerce# b) of (# c #) -> c setDoubleOffClosure :: a -> Int# -> Double# -> a setDoubleOffClosure a i b = unsafeCoerce# (panic "setDoubleOffClosure") ------------------------------------------------------------------------ --- 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 mkITbls (tc:tcs) = do itbls <- mkITbl tc itbls2 <- mkITbls tcs return (itbls `plusFM` itbls2) mkITbl :: TyCon -> IO ItblEnv mkITbl tc -- | trace ("TYCON: " ++ showSDoc (ppr tc)) False -- = error "?!?!" | not (isDataTyCon tc) = return emptyFM | n == length dcs -- paranoia; this is an assertion. = make_constr_itbls dcs where dcs = tyConDataCons tc n = tyConFamilySize tc cONSTR :: Int cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h -- Assumes constructors are numbered from zero, not one make_constr_itbls :: [DataCon] -> IO ItblEnv make_constr_itbls cons | length cons <= 8 = do is <- mapM mk_vecret_itbl (zip cons [0..]) return (listToFM is) | otherwise = do is <- mapM mk_dirret_itbl (zip cons [0..]) return (listToFM is) where mk_vecret_itbl (dcon, conNo) = mk_itbl dcon conNo (vecret_entry conNo) mk_dirret_itbl (dcon, conNo) = mk_itbl dcon conNo mci_constr_entry mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = let (tot_wds, ptr_wds, _) = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) ptrs = ptr_wds nptrs = tot_wds - ptr_wds itbl = StgInfoTable { ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs, tipe = fromIntegral cONSTR, srtlen = fromIntegral conNo, code0 = fromIntegral code0, code1 = fromIntegral code1, code2 = fromIntegral code2, code3 = fromIntegral code3, code4 = fromIntegral code4, code5 = fromIntegral code5, code6 = fromIntegral code6, code7 = fromIntegral code7 } -- Make a piece of code to jump to "entry_label". -- This is the only arch-dependent bit. -- On x86, if entry_label has an address 0xWWXXYYZZ, -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax -- which is -- B8 ZZ YY XX WW FF E0 (code0,code1,code2,code3,code4,code5,code6,code7) = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w, byte 2 entry_addr_w, byte 3 entry_addr_w, 0xFF, 0xE0, 0x90 {-nop-}) entry_addr_w :: Word32 entry_addr_w = fromIntegral (addrToInt entry_addr) in 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 (getName dcon, addr `plusPtr` 8) byte :: Int -> Word32 -> Word32 byte 0 w = w .&. 0xFF byte 1 w = (w `shiftR` 8) .&. 0xFF byte 2 w = (w `shiftR` 16) .&. 0xFF byte 3 w = (w `shiftR` 24) .&. 0xFF vecret_entry 0 = mci_constr1_entry vecret_entry 1 = mci_constr2_entry vecret_entry 2 = mci_constr3_entry vecret_entry 3 = mci_constr4_entry vecret_entry 4 = mci_constr5_entry vecret_entry 5 = mci_constr6_entry vecret_entry 6 = mci_constr7_entry vecret_entry 7 = mci_constr8_entry -- entry point for direct returns for created constr itbls foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr -- and the 8 vectored ones 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 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-} -- Ultra-minimalist version specially for constructors data StgInfoTable = StgInfoTable { ptrs :: Word16, nptrs :: Word16, srtlen :: Word16, tipe :: Word16, code0, code1, code2, code3, code4, code5, code6, code7 :: Word8 } instance Storable StgInfoTable where sizeOf itbl = (sum . map (\f -> f itbl)) [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe, fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3, fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7] alignment itbl = (sum . map (\f -> f itbl)) [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe, fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3, fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7] poke a0 itbl = do a1 <- store (ptrs itbl) (castPtr a0) a2 <- store (nptrs itbl) a1 a3 <- store (tipe itbl) a2 a4 <- store (srtlen itbl) a3 a5 <- store (code0 itbl) a4 a6 <- store (code1 itbl) a5 a7 <- store (code2 itbl) a6 a8 <- store (code3 itbl) a7 a9 <- store (code4 itbl) a8 aA <- store (code5 itbl) a9 aB <- store (code6 itbl) aA aC <- store (code7 itbl) aB return () peek a0 = do (a1,ptrs) <- load (castPtr a0) (a2,nptrs) <- load a1 (a3,tipe) <- load a2 (a4,srtlen) <- load a3 (a5,code0) <- load a4 (a6,code1) <- load a5 (a7,code2) <- load a6 (a8,code3) <- load a7 (a9,code4) <- load a8 (aA,code5) <- load a9 (aB,code6) <- load aA (aC,code7) <- load aB return StgInfoTable { ptrs = ptrs, nptrs = nptrs, srtlen = srtlen, tipe = tipe, code0 = code0, code1 = code1, code2 = code2, code3 = code3, code4 = code4, code5 = code5, code6 = code6, code7 = code7 } fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int fieldSz sel x = sizeOf (sel x) fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int fieldAl sel x = alignment (sel x) store :: Storable a => a -> Ptr a -> IO (Ptr b) store x addr = do poke addr x return (castPtr (addr `plusPtr` sizeOf x)) load :: Storable a => Ptr a -> IO (Ptr b, a) load addr = do x <- peek addr return (castPtr (addr `plusPtr` sizeOf x), x) -----------------------------------------------------------------------------q foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO () #endif \end{code}