diff options
Diffstat (limited to 'compiler/codeGen')
25 files changed, 13 insertions, 10495 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs deleted file mode 100644 index 834276bd7b..0000000000 --- a/compiler/codeGen/CgBindery.lhs +++ /dev/null @@ -1,564 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgBindery]{Utility functions related to doing @CgBindings@} - -\begin{code} - -module CgBindery ( - CgBindings, CgIdInfo, - StableLoc, VolatileLoc, - - cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - - stableIdInfo, heapIdInfo, - taggedStableIdInfo, taggedHeapIdInfo, - letNoEscapeIdInfo, idInfoToAmode, - - addBindC, addBindsC, - - nukeVolatileBinds, - nukeDeadBindings, - getLiveStackSlots, - getLiveStackBindings, - - bindArgsToStack, rebindToStack, - bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, - getArgAmode, getArgAmodes, - getCgIdInfo, - getCAddrModeIfVolatile, getVolatileRegs, - maybeLetNoEscape, - ) where - -import CgMonad -import CgHeapery -import CgStackery -import CgUtils -import CLabel -import ClosureInfo - -import DynFlags -import OldCmm -import PprCmm ( {- instance Outputable -} ) -import SMRep -import Id -import DataCon -import VarEnv -import VarSet -import Literal -import Maybes -import Name -import StgSyn -import Unique -import UniqSet -import Outputable -import FastString - -\end{code} - -%************************************************************************ -%* * -\subsection[Bindery-datatypes]{Data types} -%* * -%************************************************************************ - -@(CgBinding a b)@ is a type of finite maps from a to b. - -The assumption used to be that @lookupCgBind@ must get exactly one -match. This is {\em completely wrong} in the case of compiling -letrecs (where knot-tying is used). An initial binding is fed in (and -never evaluated); eventually, a correct binding is put into the -environment. So there can be two bindings for a given name. - -\begin{code} -type CgBindings = IdEnv CgIdInfo - -data CgIdInfo - = CgIdInfo - { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by - -- virtue of being externalised, for splittable C - , cg_rep :: CgRep - , cg_vol :: VolatileLoc - , cg_stb :: StableLoc - , cg_lf :: LambdaFormInfo - , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode - } - -mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo -mkCgIdInfo dflags id vol stb lf - = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } - where - tag - | Just con <- isDataConWorkId_maybe id, - {- Is this an identifier for a static constructor closure? -} - isNullaryRepDataCon con - {- If yes, is this a nullary constructor? - If yes, we assume that the constructor is evaluated and can - be tagged. - -} - = tagForCon dflags con - - | otherwise - = funTagLFInfo dflags lf - -voidIdInfo :: Id -> CgIdInfo -voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc - , cg_stb = VoidLoc, cg_lf = mkLFArgument id - , cg_rep = VoidArg, cg_tag = 0 } - -- Used just for VoidRep things - -data VolatileLoc -- These locations die across a call - = NoVolatileLoc - | RegLoc CmmReg -- In one of the registers (global or local) - | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure) - | VirNodeLoc ByteOff -- Cts of offset indirect from Node - -- ie *(Node+offset). - -- NB. Byte offset, because we subtract R1's - -- tag from the offset. - -mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon - -> CgIdInfo -mkTaggedCgIdInfo dflags id vol stb lf con - = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con } -\end{code} - -@StableLoc@ encodes where an Id can be found, used by -the @CgBindings@ environment in @CgBindery@. - -\begin{code} -data StableLoc - = NoStableLoc - - | VirStkLoc VirtualSpOffset -- The thing is held in this - -- stack slot - - | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the - -- value is this stack pointer - -- (as opposed to the contents of the slot) - - | StableLoc CmmExpr - | VoidLoc -- Used only for VoidRep variables. They never need to - -- be saved, so it makes sense to treat treat them as - -- having a stable location - -instance Outputable CgIdInfo where - ppr (CgIdInfo id _ vol stb _ _) - -- TODO, pretty pring the tag info - = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb] - -instance Outputable VolatileLoc where - ppr NoVolatileLoc = empty - ppr (RegLoc r) = ptext (sLit "reg") <+> ppr r - ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v - ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v - -instance Outputable StableLoc where - ppr NoStableLoc = empty - ppr VoidLoc = ptext (sLit "void") - ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v - ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v - ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a -\end{code} - -%************************************************************************ -%* * -\subsection[Bindery-idInfo]{Manipulating IdInfo} -%* * -%************************************************************************ - -\begin{code} -stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo -stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info - -heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo -heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info - -letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -letNoEscapeIdInfo dflags id sp lf_info - = mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info - -stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo dflags id sp lf_info - = mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info - -nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo -nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info - -regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo -regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info - -taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedStableIdInfo dflags id amode lf_info con - = mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con - -taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon - -> CgIdInfo -taggedHeapIdInfo dflags id offset lf_info con - = mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con - -untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo -untagNodeIdInfo dflags id offset lf_info tag - = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info - - -idInfoToAmode :: CgIdInfo -> FCode CmmExpr -idInfoToAmode info = do - dflags <- getDynFlags - let mach_rep = argMachRep dflags (cg_rep info) - - maybeTag amode -- add the tag, if we have one - | tag == 0 = amode - | otherwise = cmmOffsetB dflags amode tag - where tag = cg_tag info - case cg_vol info of { - RegLoc reg -> returnFC (CmmReg reg) ; - VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB dflags (CmmReg nodeReg) nd_off) - mach_rep) ; - VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off - ; return $! maybeTag off }; - NoVolatileLoc -> - - case cg_stb info of - StableLoc amode -> returnFC $! maybeTag amode - VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off - ; return (CmmLoad sp_rel mach_rep) } - - VirStkLNE sp_off -> getSpRelOffset sp_off - - VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info)) - -- We return a 'bottom' amode, rather than panicing now - -- In this way getArgAmode returns a pair of (VoidArg, bottom) - -- and that's exactly what we want - - NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info)) - } - -cgIdInfoId :: CgIdInfo -> Id -cgIdInfoId = cg_id - -cgIdInfoLF :: CgIdInfo -> LambdaFormInfo -cgIdInfoLF = cg_lf - -cgIdInfoArgRep :: CgIdInfo -> CgRep -cgIdInfoArgRep = cg_rep - -maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset -maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off -maybeLetNoEscape _ = Nothing -\end{code} - -%************************************************************************ -%* * -\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} -%* * -%************************************************************************ - -There are three basic routines, for adding (@addBindC@), modifying -(@modifyBindC@) and looking up (@getCgIdInfo@) bindings. - -A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. -The name should not already be bound. (nice ASSERT, eh?) - -\begin{code} -addBindC :: Id -> CgIdInfo -> Code -addBindC name stuff_to_bind = do - binds <- getBinds - setBinds $ extendVarEnv binds name stuff_to_bind - -addBindsC :: [(Id, CgIdInfo)] -> Code -addBindsC new_bindings = do - binds <- getBinds - let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) - binds - new_bindings - setBinds new_binds - -modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code -modifyBindC name mangle_fn = do - binds <- getBinds - setBinds $ modifyVarEnv mangle_fn binds name - -getCgIdInfo :: Id -> FCode CgIdInfo -getCgIdInfo id - = do { dflags <- getDynFlags - ; -- Try local bindings first - ; local_binds <- getBinds - ; case lookupVarEnv local_binds id of { - Just info -> return info ; - Nothing -> do - - { -- Try top-level bindings - static_binds <- getStaticBinds - ; case lookupVarEnv static_binds id of { - Just info -> return info ; - Nothing -> - - -- Should be imported; make up a CgIdInfo for it - let - name = idName id - in - if isExternalName name then do - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) - return (stableIdInfo dflags id ext_lbl (mkLFImported id)) - else - if isVoidArg (idCgRep id) then - -- Void things are never in the environment - return (voidIdInfo id) - else - -- Bug - cgLookupPanic id - }}}} - - -cgLookupPanic :: Id -> FCode a -cgLookupPanic id - = do static_binds <- getStaticBinds - local_binds <- getBinds --- srt <- getSRTLabel - pprPanic "cgLookupPanic (probably invalid Core; try -dcore-lint)" - (vcat [ppr id, - ptext (sLit "static binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], - ptext (sLit "local binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] --- ptext (sLit "SRT label") <+> pprCLabel srt - ]) -\end{code} - -%************************************************************************ -%* * -\subsection[Bindery-nuke-volatile]{Nuking volatile bindings} -%* * -%************************************************************************ - -We sometimes want to nuke all the volatile bindings; we must be sure -we don't leave any (NoVolatile, NoStable) binds around... - -\begin{code} -nukeVolatileBinds :: CgBindings -> CgBindings -nukeVolatileBinds binds - = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds)) - where - keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc - keep_if_stable info acc - = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc -\end{code} - - -%************************************************************************ -%* * -\subsection[lookup-interface]{Interface functions to looking up bindings} -%* * -%************************************************************************ - -\begin{code} -getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr) -getCAddrModeIfVolatile id - = do { info <- getCgIdInfo id - ; case cg_stb info of - NoStableLoc -> do -- Aha! So it is volatile! - amode <- idInfoToAmode info - return $ Just amode - _ -> return Nothing } -\end{code} - -@getVolatileRegs@ gets a set of live variables, and returns a list of -all registers on which these variables depend. These are the regs -which must be saved and restored across any C calls. If a variable is -both in a volatile location (depending on a register) {\em and} a -stable one (notably, on the stack), we modify the current bindings to -forget the volatile one. - -\begin{code} -getVolatileRegs :: StgLiveVars -> FCode [GlobalReg] -getVolatileRegs vars = do - do { stuff <- mapFCs snaffle_it (varSetElems vars) - ; returnFC $ catMaybes stuff } - where - snaffle_it var = do - { info <- getCgIdInfo var - ; let - -- commoned-up code... - consider_reg reg - = -- We assume that all regs can die across C calls - -- We leave it to the save-macros to decide which - -- regs *really* need to be saved. - case cg_stb info of - NoStableLoc -> returnFC (Just reg) -- got one! - _ -> do - { -- has both volatile & stable locations; - -- force it to rely on the stable location - modifyBindC var nuke_vol_bind - ; return Nothing } - - ; case cg_vol info of - RegLoc (CmmGlobal reg) -> consider_reg reg - VirNodeLoc _ -> consider_reg node - _ -> returnFC Nothing -- Local registers - } - - nuke_vol_bind info = info { cg_vol = NoVolatileLoc } - -getArgAmode :: StgArg -> FCode (CgRep, CmmExpr) -getArgAmode (StgVarArg var) - = do { info <- getCgIdInfo var - ; amode <- idInfoToAmode info - ; return (cgIdInfoArgRep info, amode ) } - -getArgAmode (StgLitArg lit) - = do { cmm_lit <- cgLit lit - ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } - -getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] -getArgAmodes [] = returnFC [] -getArgAmodes (atom:atoms) - = do { amode <- getArgAmode atom - ; amodes <- getArgAmodes atoms - ; return ( amode : amodes ) } -\end{code} - -%************************************************************************ -%* * -\subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names} -%* * -%************************************************************************ - -\begin{code} -bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code -bindArgsToStack args - = do dflags <- getDynFlags - let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id)) - mapCs bind args - -bindArgsToRegs :: [(Id, GlobalReg)] -> Code -bindArgsToRegs args - = mapCs bind args - where - bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg) - -bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code -bindNewToNode id offset lf_info - = do dflags <- getDynFlags - addBindC id (nodeIdInfo dflags id offset lf_info) - -bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code -bindNewToUntagNode id offset lf_info tag - = do dflags <- getDynFlags - addBindC id (untagNodeIdInfo dflags id offset lf_info tag) - --- Create a new temporary whose unique is that in the id, --- bind the id to it, and return the addressing mode for the --- temporary. -bindNewToTemp :: Id -> FCode LocalReg -bindNewToTemp id - = do dflags <- getDynFlags - let uniq = getUnique id - temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id)) - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about - addBindC id (regIdInfo dflags id (CmmLocal temp_reg) lf_info) - return temp_reg - -bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code -bindNewToReg name reg lf_info - = do dflags <- getDynFlags - let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info - addBindC name info - -rebindToStack :: Id -> VirtualSpOffset -> Code -rebindToStack name offset - = modifyBindC name replace_stable_fn - where - replace_stable_fn info = info { cg_stb = VirStkLoc offset } -\end{code} - -%************************************************************************ -%* * -\subsection[CgMonad-deadslots]{Finding dead stack slots} -%* * -%************************************************************************ - -nukeDeadBindings does the following: - - - Removes all bindings from the environment other than those - for variables in the argument to nukeDeadBindings. - - Collects any stack slots so freed, and returns them to the stack free - list. - - Moves the virtual stack pointer to point to the topmost used - stack locations. - -You can have multi-word slots on the stack (where a Double# used to -be, for instance); if dead, such a slot will be reported as *several* -offsets (one per word). - -Probably *naughty* to look inside monad... - -\begin{code} -nukeDeadBindings :: StgLiveVars -- All the *live* variables - -> Code -nukeDeadBindings live_vars = do - dflags <- getDynFlags - binds <- getBinds - let (dead_stk_slots, bs') = - dead_slots dflags live_vars - [] [] - [ (cg_id b, b) | b <- varEnvElts binds ] - setBinds $ mkVarEnv bs' - freeStackSlots dead_stk_slots -\end{code} - -Several boring auxiliary functions to do the dirty work. - -\begin{code} -dead_slots :: DynFlags - -> StgLiveVars - -> [(Id,CgIdInfo)] - -> [VirtualSpOffset] - -> [(Id,CgIdInfo)] - -> ([VirtualSpOffset], [(Id,CgIdInfo)]) - --- dead_slots carries accumulating parameters for --- filtered bindings, dead slots -dead_slots _ _ fbs ds [] - = (ds, reverse fbs) -- Finished; rm the dups, if any - -dead_slots dflags live_vars fbs ds ((v,i):bs) - | v `elementOfUniqSet` live_vars - = dead_slots dflags live_vars ((v,i):fbs) ds bs - -- Live, so don't record it in dead slots - -- Instead keep it in the filtered bindings - - | otherwise - = case cg_stb i of - VirStkLoc offset - | size > 0 - -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - - _ -> dead_slots dflags live_vars fbs ds bs - where - size :: WordOff - size = cgRepSizeW dflags (cg_rep i) - -getLiveStackSlots :: FCode [VirtualSpOffset] --- Return the offsets of slots in stack containig live pointers -getLiveStackSlots - = do { binds <- getBinds - ; return [off | CgIdInfo { cg_stb = VirStkLoc off, - cg_rep = rep } <- varEnvElts binds, - isFollowableArg rep] } - -getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)] -getLiveStackBindings - = do { binds <- getBinds - ; return [(off, bind) | - bind <- varEnvElts binds, - CgIdInfo { cg_stb = VirStkLoc off, - cg_rep = rep} <- [bind], - isFollowableArg rep] } -\end{code} - diff --git a/compiler/codeGen/CgBindery.lhs-boot b/compiler/codeGen/CgBindery.lhs-boot deleted file mode 100644 index e504a6a9ba..0000000000 --- a/compiler/codeGen/CgBindery.lhs-boot +++ /dev/null @@ -1,11 +0,0 @@ -\begin{code} -module CgBindery where -import VarEnv( IdEnv ) - -data CgIdInfo -data VolatileLoc -data StableLoc -type CgBindings = IdEnv CgIdInfo - -nukeVolatileBinds :: CgBindings -> CgBindings -\end{code}
\ No newline at end of file diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs deleted file mode 100644 index e4095fd027..0000000000 --- a/compiler/codeGen/CgCallConv.hs +++ /dev/null @@ -1,414 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004-2006 --- --- CgCallConv --- --- The datatypes and functions here encapsulate the --- calling and return conventions used by the code generator. --- ------------------------------------------------------------------------------ - -module CgCallConv ( - -- Argument descriptors - mkArgDescr, - - -- Liveness - mkRegLiveness, - - -- Register assignment - assignCallRegs, assignReturnRegs, assignPrimOpCallRegs, - - -- Calls - constructSlowCall, slowArgs, slowCallPattern, - - -- Returns - dataReturnConvPrim, - getSequelAmode - ) where - -import CgMonad -import CgProf -import SMRep - -import OldCmm -import CLabel - -import CgStackery -import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg ) -import OldCmmUtils -import Maybes -import Id -import Name -import Util -import DynFlags -import Module -import FastString -import Outputable -import Platform -import Data.Bits - -------------------------------------------------------------------------- --- --- Making argument descriptors --- --- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails --- --- Void arguments aren't important, therefore (contrast constructSlowCall) --- -------------------------------------------------------------------------- - --- bring in ARG_P, ARG_N, etc. -#include "../includes/rts/storage/FunTypes.h" - -------------------------- -mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = do dflags <- getDynFlags - let arg_bits = argBits dflags arg_reps - arg_reps = filter nonVoidArg (map idCgRep args) - -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - -argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits _ [] = [] -argBits dflags (PtrArg : args) = False : argBits dflags args -argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args - -stdPattern :: [CgRep] -> Maybe Int -stdPattern reps - = case reps of - [] -> Just ARG_NONE -- just void args, probably - - [PtrArg] -> Just ARG_P - [FloatArg] -> Just ARG_F - [DoubleArg] -> Just ARG_D - [LongArg] -> Just ARG_L - [NonPtrArg] -> Just ARG_N - - [NonPtrArg,NonPtrArg] -> Just ARG_NN - [NonPtrArg,PtrArg] -> Just ARG_NP - [PtrArg,NonPtrArg] -> Just ARG_PN - [PtrArg,PtrArg] -> Just ARG_PP - - [NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN - [NonPtrArg,NonPtrArg,PtrArg] -> Just ARG_NNP - [NonPtrArg,PtrArg,NonPtrArg] -> Just ARG_NPN - [NonPtrArg,PtrArg,PtrArg] -> Just ARG_NPP - [PtrArg,NonPtrArg,NonPtrArg] -> Just ARG_PNN - [PtrArg,NonPtrArg,PtrArg] -> Just ARG_PNP - [PtrArg,PtrArg,NonPtrArg] -> Just ARG_PPN - [PtrArg,PtrArg,PtrArg] -> Just ARG_PPP - - [PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPP - [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPP - [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP - _ -> Nothing - - -------------------------------------------------------------------------- --- --- Bitmap describing register liveness --- across GC when doing a "generic" heap check --- (a RET_DYN stack frame). --- --- NB. Must agree with these macros (currently in StgMacros.h): --- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS(). -------------------------------------------------------------------------- - -mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord -mkRegLiveness dflags regs ptrs nptrs - = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|. - (toStgWord dflags (toInteger ptrs) `shiftL` 24) .|. - all_non_ptrs `xor` toStgWord dflags (reg_bits regs) - where - all_non_ptrs = toStgWord dflags 0xff - - reg_bits [] = 0 - reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id) - = (1 `shiftL` (i - 1)) .|. reg_bits regs - reg_bits (_ : regs) - = reg_bits regs - -------------------------------------------------------------------------- --- --- Pushing the arguments for a slow call --- -------------------------------------------------------------------------- - --- For a slow call, we must take a bunch of arguments and intersperse --- some stg_ap_<pattern>_ret_info return addresses. -constructSlowCall - :: [(CgRep,CmmExpr)] - -> (CLabel, -- RTS entry point for call - [(CgRep,CmmExpr)], -- args to pass to the entry point - [(CgRep,CmmExpr)]) -- stuff to save on the stack - - -- don't forget the zero case -constructSlowCall [] - = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], []) - -constructSlowCall amodes - = (stg_ap_pat, these, rest) - where - stg_ap_pat = mkRtsApFastLabel arg_pat - (arg_pat, these, rest) = matchSlowPattern amodes - --- | 'slowArgs' takes a list of function arguments and prepares them for --- pushing on the stack for "extra" arguments to a function which requires --- fewer arguments than we currently have. -slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)] -slowArgs _ [] = [] -slowArgs dflags amodes - | gopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest - | otherwise = this_pat ++ slowArgs dflags rest - where - (arg_pat, args, rest) = matchSlowPattern amodes - stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat - this_pat = (NonPtrArg, mkLblExpr stg_ap_pat) : args - save_cccs = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)] - save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") - -matchSlowPattern :: [(CgRep,CmmExpr)] - -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) -matchSlowPattern amodes = (arg_pat, these, rest) - where (arg_pat, n) = slowCallPattern (map fst amodes) - (these, rest) = splitAt n amodes - --- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [CgRep] -> (FastString, Int) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3) -slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3) -slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2) -slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2) -slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1) -slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1) -slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1) -slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1) -slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1) -slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1) -slowCallPattern _ = panic "CgStackery.slowCallPattern" - -------------------------------------------------------------------------- --- --- Return conventions --- -------------------------------------------------------------------------- - -dataReturnConvPrim :: CgRep -> CmmReg -dataReturnConvPrim PtrArg = CmmGlobal (VanillaReg 1 VGcPtr) -dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr) -dataReturnConvPrim LongArg = CmmGlobal (LongReg 1) -dataReturnConvPrim FloatArg = CmmGlobal (FloatReg 1) -dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1) -dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void" - - --- getSequelAmode returns an amode which refers to an info table. The info --- table will always be of the RET_(BIG|SMALL) kind. We're careful --- not to handle real code pointers, just in case we're compiling for --- an unregisterised/untailcallish architecture, where info pointers and --- code pointers aren't the same. --- DIRE WARNING. --- The OnStack case of sequelToAmode delivers an Amode which is only --- valid just before the final control transfer, because it assumes --- that Sp is pointing to the top word of the return address. This --- seems unclean but there you go. - -getSequelAmode :: FCode CmmExpr -getSequelAmode - = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo - ; case sequel of - OnStack -> do { dflags <- getDynFlags - ; sp_rel <- getSpRelOffset virt_sp - ; returnFC (CmmLoad sp_rel (bWord dflags)) } - - CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) - } - -------------------------------------------------------------------------- --- --- Register assignment --- -------------------------------------------------------------------------- - --- How to assign registers for --- --- 1) Calling a fast entry point. --- 2) Returning an unboxed tuple. --- 3) Invoking an out-of-line PrimOp. --- --- Registers are assigned in order. --- --- If we run out, we don't attempt to assign any further registers (even --- though we might have run out of only one kind of register); we just --- return immediately with the left-overs specified. --- --- The alternative version @assignAllRegs@ uses the complete set of --- registers, including those that aren't mapped to real machine --- registers. This is used for calling special RTS functions and PrimOps --- which expect their arguments to always be in the same registers. - -type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign - -> ([(a, GlobalReg)], -- Register assignment in same order - -- for *initial segment of* input list - -- (but reversed; doesn't matter) - -- VoidRep args do not appear here - [(CgRep,a)]) -- Leftover arg or result values - -assignCallRegs :: DynFlags -> AssignRegs a -assignPrimOpCallRegs :: DynFlags -> AssignRegs a -assignReturnRegs :: DynFlags -> AssignRegs a - -assignCallRegs dflags args - = assign_regs args (mkRegTbl dflags [node]) - -- The entry convention for a function closure - -- never uses Node for argument passing; instead - -- Node points to the function closure itself - -assignPrimOpCallRegs dflags args - = assign_regs args (mkRegTbl_allRegs dflags []) - -- For primops, *all* arguments must be passed in registers - -assignReturnRegs dflags args - -- when we have a single non-void component to return, use the normal - -- unpointed return convention. This make various things simpler: it - -- means we can assume a consistent convention for IO, which is useful - -- when writing code that relies on knowing the IO return convention in - -- the RTS (primops, especially exception-related primops). - -- Also, the bytecode compiler assumes this when compiling - -- case expressions and ccalls, so it only needs to know one set of - -- return conventions. - | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep - = ([(arg, r)], []) - | otherwise - = assign_regs args (mkRegTbl dflags []) - -- For returning unboxed tuples etc, - -- we use all regs - where - non_void_args = filter ((/= VoidArg).fst) args - -assign_regs :: [(CgRep,a)] -- Arg or result values to assign - -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs - -> ([(a, GlobalReg)], [(CgRep, a)]) -assign_regs args supply - = go args [] supply - where - go [] acc _ = (acc, []) -- Return the results reversed (doesn't matter) - go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and - = go args acc supply -- there's nothing to bind them to - go ((rep,arg) : args) acc supply - = case assign_reg rep supply of - Just (reg, supply') -> go args ((arg,reg):acc) supply' - Nothing -> (acc, (rep,arg):args) -- No more regs - -assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs) -assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls)) -assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d, (vs, fs, ds, ls)) -assign_reg LongArg (vs, fs, ds, l:ls) = Just (LongReg l, (vs, fs, ds, ls)) -assign_reg PtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls)) -assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls)) - -- PtrArg and NonPtrArg both go in a vanilla register -assign_reg _ _ = Nothing - - -------------------------------------------------------------------------- --- --- Register supplies --- -------------------------------------------------------------------------- - --- Vanilla registers can contain pointers, Ints, Chars. --- Floats and doubles have separate register supplies. --- --- We take these register supplies from the *real* registers, i.e. those --- that are guaranteed to map to machine registers. - -useVanillaRegs :: DynFlags -> Int -useVanillaRegs dflags - | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Vanilla_REG dflags -useFloatRegs :: DynFlags -> Int -useFloatRegs dflags - | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Float_REG dflags -useDoubleRegs :: DynFlags -> Int -useDoubleRegs dflags - | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Double_REG dflags -useLongRegs :: DynFlags -> Int -useLongRegs dflags - | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Long_REG dflags - -vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int] -vanillaRegNos dflags = regList $ useVanillaRegs dflags -floatRegNos dflags = regList $ useFloatRegs dflags -doubleRegNos dflags = regList $ useDoubleRegs dflags -longRegNos dflags = regList $ useLongRegs dflags - -allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos - :: DynFlags -> [Int] -allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags -allFloatRegNos dflags = regList $ mAX_Float_REG dflags -allDoubleRegNos dflags = regList $ mAX_Double_REG dflags -allLongRegNos dflags = regList $ mAX_Long_REG dflags - -regList :: Int -> [Int] -regList n = [1 .. n] - -type AvailRegs = ( [Int] -- available vanilla regs. - , [Int] -- floats - , [Int] -- doubles - , [Int] -- longs (int64 and word64) - ) - -mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs -mkRegTbl dflags regs_in_use - = mkRegTbl' dflags regs_in_use - vanillaRegNos floatRegNos doubleRegNos longRegNos - -mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs -mkRegTbl_allRegs dflags regs_in_use - = mkRegTbl' dflags regs_in_use - allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos - -mkRegTbl' :: DynFlags -> [GlobalReg] - -> (DynFlags -> [Int]) - -> (DynFlags -> [Int]) - -> (DynFlags -> [Int]) - -> (DynFlags -> [Int]) - -> ([Int], [Int], [Int], [Int]) -mkRegTbl' dflags regs_in_use vanillas floats doubles longs - = (ok_vanilla, ok_float, ok_double, ok_long) - where - ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) - (vanillas dflags) - -- ptrhood isn't looked at, hence we can use any old rep. - ok_float = mapCatMaybes (select FloatReg) (floats dflags) - ok_double = mapCatMaybes (select DoubleReg) (doubles dflags) - ok_long = mapCatMaybes (select LongReg) (longs dflags) - - select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int - -- one we've unboxed the Int, we make a GlobalReg - -- and see if it is already in use; if not, return its number. - - select mk_reg_fun cand - = let - reg = mk_reg_fun cand - in - if reg `not_elem` regs_in_use - then Just cand - else Nothing - where - not_elem = isn'tIn "mkRegTbl" - - diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs deleted file mode 100644 index 595a30e7a1..0000000000 --- a/compiler/codeGen/CgCase.lhs +++ /dev/null @@ -1,673 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} - -module CgCase ( - cgCase, - saveVolatileVarsAndRegs, - restoreCurrentCostCentre - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} CgExpr ( cgExpr ) - -import CgMonad -import CgBindery -import CgCon -import CgHeapery -import CgCallConv -import CgStackery -import CgTailCall -import CgPrimOp -import CgForeignCall -import CgUtils -import CgProf -import CgInfoTbls - -import ClosureInfo -import OldCmmUtils -import OldCmm - -import DynFlags -import StgSyn -import Id -import ForeignCall -import VarSet -import CoreSyn -import PrimOp -import Type -import TyCon -import Util -import Outputable -import FastString - -import Control.Monad (when) -\end{code} - -\begin{code} -data GCFlag - = GCMayHappen -- The scrutinee may involve GC, so everything must be - -- tidy before the code for the scrutinee. - - | NoGC -- The scrutinee is a primitive value, or a call to a - -- primitive op which does no GC. Hence the case can - -- be done inline, without tidying up first. -\end{code} - -It is quite interesting to decide whether to put a heap-check -at the start of each alternative. Of course we certainly have -to do so if the case forces an evaluation, or if there is a primitive -op which can trigger GC. - -A more interesting situation is this: - - \begin{verbatim} - !A!; - ...A... - case x# of - 0# -> !B!; ...B... - default -> !C!; ...C... - \end{verbatim} - -where \tr{!x!} indicates a possible heap-check point. The heap checks -in the alternatives {\em can} be omitted, in which case the topmost -heapcheck will take their worst case into account. - -In favour of omitting \tr{!B!}, \tr{!C!}: - - - {\em May} save a heap overflow test, - if ...A... allocates anything. The other advantage - of this is that we can use relative addressing - from a single Hp to get at all the closures so allocated. - - - No need to save volatile vars etc across the case - -Against: - - - May do more allocation than reqd. This sometimes bites us - badly. For example, nfib (ha!) allocates about 30\% more space if the - worst-casing is done, because many many calls to nfib are leaf calls - which don't need to allocate anything. - - This never hurts us if there is only one alternative. - -\begin{code} -cgCase :: StgExpr - -> StgLiveVars - -> StgLiveVars - -> Id - -> AltType - -> [StgAlt] - -> Code -\end{code} - -Special case #1: case of literal. - -\begin{code} -cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr - alt_type@(PrimAlt _) alts - = do { tmp_reg <- bindNewToTemp bndr - ; cm_lit <- cgLit lit - ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit)) - ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } -\end{code} - -Special case #2: scrutinising a primitive-typed variable. No -evaluation required. We don't save volatile variables, nor do we do a -heap-check in the alternatives. Instead, the heap usage of the -alternatives is worst-cased and passed upstream. This can result in -allocating more heap than strictly necessary, but it will sometimes -eliminate a heap check altogether. - -\begin{code} -cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr - (PrimAlt _) [(DEFAULT,bndrs,_,rhs)] - | isVoidArg (idCgRep bndr) - = ASSERT( null bndrs ) - WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr) - cgExpr rhs - -cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr - alt_type@(PrimAlt _) alts - -- Note [ticket #3132]: we might be looking at a case of a lifted Id - -- that was cast to an unlifted type. The Id will always be bottom, - -- but we don't want the code generator to fall over here. If we - -- just emit an assignment here, the assignment will be - -- type-incorrect Cmm. Hence we check that the types match, and if - -- they don't we'll fall through and emit the usual enter/return - -- code. Test case: codeGen/should_compile/3132.hs - | isUnLiftedType (idType v) - - -- However, we also want to allow an assignment to be generated - -- in the case when the types are compatible, because this allows - -- some slightly-dodgy but occasionally-useful casts to be used, - -- such as in RtClosureInspect where we cast an HValue to a MutVar# - -- so we can print out the contents of the MutVar#. If we generate - -- code that enters the HValue, then we'll get a runtime panic, because - -- the HValue really is a MutVar#. The types are compatible though, - -- so we can just generate an assignment. - || reps_compatible - = do { when (not reps_compatible) $ - panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" - - -- Careful! we can't just bind the default binder to the same thing - -- as the scrutinee, since it might be a stack location, and having - -- two bindings pointing at the same stack locn doesn't work (it - -- confuses nukeDeadBindings). Hence, use a new temp. - ; v_info <- getCgIdInfo v - ; amode <- idInfoToAmode v_info - ; tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign (CmmLocal tmp_reg) amode) - - ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } - where - reps_compatible = idCgRep v == idCgRep bndr -\end{code} - -Special case #2.5; seq# - - case seq# a s of v - (# s', a' #) -> e - - ==> - - case a of v - (# s', a' #) -> e - - (taking advantage of the fact that the return convention for (# State#, a #) - is the same as the return convention for just 'a') - -\begin{code} -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) - live_in_whole_case live_in_alts bndr alt_type alts - = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts -\end{code} - -Special case #3: inline PrimOps and foreign calls. - -\begin{code} -cgCase (StgOpApp (StgPrimOp primop) args _) - _live_in_whole_case live_in_alts bndr alt_type alts - | not (primOpOutOfLine primop) - = cgInlinePrimOp primop args bndr alt_type live_in_alts alts -\end{code} - -TODO: Case-of-case of primop can probably be done inline too (but -maybe better to translate it out beforehand). See -ghc/lib/misc/PackedString.lhs for examples where this crops up (with -4.02). - -Special case #4: inline foreign calls: an unsafe foreign call can be done -right here, just like an inline primop. - -\begin{code} -cgCase (StgOpApp (StgFCallOp fcall _) args _) - _live_in_whole_case live_in_alts _bndr _alt_type alts - | unsafe_foreign_call - = ASSERT( isSingleton alts ) - do -- *must* be an unboxed tuple alt. - -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. - { res_tmps <- mapFCs bindNewToTemp non_void_res_ids - ; let res_hints = map (typeForeignHint.idType) non_void_res_ids - ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts - ; cgExpr rhs } - where - (_, res_ids, _, rhs) = head alts - non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids - - unsafe_foreign_call - = case fcall of - CCall (CCallSpec _ _ s) -> not (playSafe s) -\end{code} - -Special case: scrutinising a non-primitive variable. -This can be done a little better than the general case, because -we can reuse/trim the stack slot holding the variable (if it is in one). - -\begin{code} -cgCase (StgApp fun args) - _live_in_whole_case live_in_alts bndr alt_type alts - = do { fun_info <- getCgIdInfo fun - ; arg_amodes <- getArgAmodes args - - -- Nuking dead bindings *before* calculating the saves is the - -- value-add here. We might end up freeing up some slots currently - -- occupied by variables only required for the call. - -- NOTE: we need to look up the variables used in the call before - -- doing this, because some of them may not be in the environment - -- afterward. - ; nukeDeadBindings live_in_alts - ; (save_assts, alts_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_alts - - ; scrut_eob_info - <- forkEval alts_eob_info - (allocStackTop retAddrSizeW >> nopC) - (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - - ; setEndOfBlockInfo scrut_eob_info - (performTailCall fun_info arg_amodes save_assts) } -\end{code} - -Note about return addresses: we *always* push a return address, even -if because of an optimisation we end up jumping direct to the return -code (not through the address itself). The alternatives always assume -that the return address is on the stack. The return address is -required in case the alternative performs a heap check, since it -encodes the liveness of the slots in the activation record. - -On entry to the case alternative, we can re-use the slot containing -the return address immediately after the heap check. That's what the -deAllocStackTop call is doing above. - -Finally, here is the general case. - -\begin{code} -cgCase expr live_in_whole_case live_in_alts bndr alt_type alts - = do { -- Figure out what volatile variables to save - nukeDeadBindings live_in_whole_case - - ; (save_assts, alts_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_alts - - -- Save those variables right now! - ; emitStmts save_assts - - -- generate code for the alts - ; scrut_eob_info - <- forkEval alts_eob_info - (do { nukeDeadBindings live_in_alts - ; allocStackTop retAddrSizeW -- space for retn address - ; nopC }) - (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - - ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) - } -\end{code} - -There's a lot of machinery going on behind the scenes to manage the -stack pointer here. forkEval takes the virtual Sp and free list from -the first argument, and turns that into the *real* Sp for the second -argument. It also uses this virtual Sp as the args-Sp in the EOB info -returned, so that the scrutinee will trim the real Sp back to the -right place before doing whatever it does. - --SDM (who just spent an hour figuring this out, and didn't want to - forget it). - -Why don't we push the return address just before evaluating the -scrutinee? Because the slot reserved for the return address might -contain something useful, so we wait until performing a tail call or -return before pushing the return address (see -CgTailCall.pushReturnAddress). - -This also means that the environment doesn't need to know about the -free stack slot for the return address (for generating bitmaps), -because we don't reserve it until just before the eval. - -TODO!! Problem: however, we have to save the current cost centre -stack somewhere, because at the eval point the current CCS might be -different. So we pick a free stack slot and save CCCS in it. One -consequence of this is that activation records on the stack don't -follow the layout of closures when we're profiling. The CCS could be -anywhere within the record). - -%************************************************************************ -%* * - Inline primops -%* * -%************************************************************************ - -\begin{code} -cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars - -> [(AltCon, [Id], [Bool], StgExpr)] - -> Code -cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts - | isVoidArg (idCgRep bndr) - = ASSERT( con == DEFAULT && isSingleton alts && null bs ) - do { -- VOID RESULT; just sequencing, - -- so get in there and do it - -- The bndr should not occur, so no need to bind it - cgPrimOp [] primop args live_in_alts - ; cgExpr rhs } - where - (con,bs,_,rhs) = head alts - -cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts - = do { -- PRIMITIVE ALTS, with non-void result - tmp_reg <- bindNewToTemp bndr - ; cgPrimOp [tmp_reg] primop args live_in_alts - ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts } - -cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts - = ASSERT( isSingleton alts ) - do { -- UNBOXED TUPLE ALTS - -- No heap check, no yield, just get in there and do it. - -- NB: the case binder isn't bound to anything; - -- it has a unboxed tuple type - - res_tmps <- mapFCs bindNewToTemp non_void_res_ids - ; cgPrimOp res_tmps primop args live_in_alts - ; cgExpr rhs } - where - (_, res_ids, _, rhs) = head alts - non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids - -cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts - = do { -- ENUMERATION TYPE RETURN - -- Typical: case a ># b of { True -> ..; False -> .. } - -- The primop itself returns an index into the table of - -- closures for the enumeration type. - tag_amode <- ASSERT( isEnumerationTyCon tycon ) - do_enum_primop primop - - -- Bind the default binder if necessary - -- (avoiding it avoids the assignment) - -- The deadness info is set by StgVarInfo - ; whenC (not (isDeadBinder bndr)) - (do { dflags <- getDynFlags - ; tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign - (CmmLocal tmp_reg) - (tagToClosure dflags tycon tag_amode)) }) - - -- Compile the alts - ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} - (AlgAlt tycon) alts - - -- Do the switch - ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1) - } - where - - do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result - do_enum_primop TagToEnumOp -- No code! - | [arg] <- args = do - (_,e) <- getArgAmode arg - return e - do_enum_primop primop - = do dflags <- getDynFlags - tmp <- newTemp (bWord dflags) - cgPrimOp [tmp] primop args live_in_alts - returnFC (CmmReg (CmmLocal tmp)) - -cgInlinePrimOp _ _ bndr _ _ _ - = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) -\end{code} - -%************************************************************************ -%* * -\subsection[CgCase-alts]{Alternatives} -%* * -%************************************************************************ - -@cgEvalAlts@ returns an addressing mode for a continuation for the -alternatives of a @case@, used in a context when there -is some evaluation to be done. - -\begin{code} -cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any - -> Id - -> AltType - -> [StgAlt] - -> FCode Sequel -- Any addr modes inside are guaranteed - -- to be a label so that we can duplicate it - -- without risk of duplicating code - -cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts - = do { let rep = tyConCgRep tycon - reg = dataReturnConvPrim rep -- Bottom for voidRep - - ; abs_c <- forkProc $ do - { -- Bind the case binder, except if it's void - -- (reg is bottom in that case) - whenC (nonVoidArg rep) $ - bindNewToReg bndr reg (mkLFArgument bndr) - ; restoreCurrentCostCentre cc_slot True - ; cgPrimAlts GCMayHappen alt_type reg alts } - - ; lbl <- emitReturnTarget (idName bndr) abs_c - ; returnFC (CaseAlts lbl Nothing bndr) } - -cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)] - = -- Unboxed tuple case - -- By now, the simplifier should have have turned it - -- into case e of (# a,b #) -> e - -- There shouldn't be a - -- case e of DEFAULT -> e - ASSERT2( case con of { DataAlt _ -> True; _ -> False }, - text "cgEvalAlts: dodgy case of unboxed tuple type" ) - do { -- forkAbsC for the RHS, so that the envt is - -- not changed for the emitReturn call - abs_c <- forkProc $ do - { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args - -- Restore the CC *after* binding the tuple components, - -- so that we get the stack offset of the saved CC right. - ; restoreCurrentCostCentre cc_slot True - -- Generate a heap check if necessary - -- and finally the code for the alternative - ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts - (cgExpr rhs) } - ; lbl <- emitReturnTarget (idName bndr) abs_c - ; returnFC (CaseAlts lbl Nothing bndr) } - -cgEvalAlts cc_slot bndr alt_type alts - = -- Algebraic and polymorphic case - do { -- Bind the default binder - bindNewToReg bndr nodeReg (mkLFArgument bndr) - - -- Generate sequel info for use downstream - -- At the moment, we only do it if the type is vector-returnable. - -- Reason: if not, then it costs extra to label the - -- alternatives, because we'd get return code like: - -- - -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } - -- - -- which is worse than having the alt code in the switch statement - - ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts - - ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) - alts mb_deflt fam_sz - - ; returnFC (CaseAlts lbl branches bndr) } - where - fam_sz = case alt_type of - AlgAlt tc -> tyConFamilySize tc - PolyAlt -> 0 - PrimAlt _ -> panic "cgEvalAlts: PrimAlt" - UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" -\end{code} - - -HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If -we do an inlining of the case no separate functions for returning are -created, so we don't have to generate a GRAN_YIELD in that case. This info -must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be -emitted). Hence, the new Bool arg to cgAlgAltRhs. - -%************************************************************************ -%* * -\subsection[CgCase-alg-alts]{Algebraic alternatives} -%* * -%************************************************************************ - -In @cgAlgAlts@, none of the binders in the alternatives are -assumed to be yet bound. - -HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The -last arg of cgAlgAlts indicates if we want a context switch at the -beginning of each alternative. Normally we want that. The only exception -are inlined alternatives. - -\begin{code} -cgAlgAlts :: GCFlag - -> Maybe VirtualSpOffset - -> AltType -- ** AlgAlt or PolyAlt only ** - -> [StgAlt] -- The alternatives - -> FCode ( [(ConTagZ, CgStmts)], -- The branches - Maybe CgStmts ) -- The default case - -cgAlgAlts gc_flag cc_slot alt_type alts - = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts] - let - mb_deflt = case alts of -- DEFAULT is always first, if present - ((DEFAULT,blks) : _) -> Just blks - _ -> Nothing - - branches = [(dataConTagZ con, blks) - | (DataAlt con, blks) <- alts] - return (branches, mb_deflt) - - -cgAlgAlt :: GCFlag - -> Maybe VirtualSpOffset -- Turgid state - -> AltType -- ** AlgAlt or PolyAlt only ** - -> StgAlt - -> FCode (AltCon, CgStmts) - -cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs) - = do { abs_c <- getCgStmts $ do - { bind_con_args con args - ; restoreCurrentCostCentre cc_slot True - ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } - ; return (con, abs_c) } - where - bind_con_args DEFAULT _ = nopC - bind_con_args (DataAlt dc) args = bindConArgs dc args - bind_con_args (LitAlt _) _ = panic "cgAlgAlt: LitAlt" -\end{code} - - -%************************************************************************ -%* * -\subsection[CgCase-prim-alts]{Primitive alternatives} -%* * -%************************************************************************ - -@cgPrimAlts@ generates suitable a @CSwitch@ -for dealing with the alternatives of a primitive @case@, given an -addressing mode for the thing to scrutinise. It also keeps track of -the maximum stack depth encountered down any branch. - -As usual, no binders in the alternatives are yet bound. - -\begin{code} -cgPrimAlts :: GCFlag - -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck - -> CmmReg -- Scrutinee - -> [StgAlt] -- Alternatives - -> Code --- NB: cgPrimAlts emits code that does the case analysis. --- It's often used in inline situations, rather than to genearte --- a labelled return point. That's why its interface is a little --- different to cgAlgAlts --- --- INVARIANT: the default binder is already bound -cgPrimAlts gc_flag alt_type scrutinee alts - = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts) - ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default - alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] - ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC } - -cgPrimAlt :: GCFlag - -> AltType - -> StgAlt -- The alternative - -> FCode (AltCon, CgStmts) -- Its compiled form - -cgPrimAlt gc_flag alt_type (con, [], [], rhs) - = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } ) - do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) - ; returnFC (con, abs_c) } -cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists" -\end{code} - - -%************************************************************************ -%* * -\subsection[CgCase-tidy]{Code for tidying up prior to an eval} -%* * -%************************************************************************ - -\begin{code} -maybeAltHeapCheck - :: GCFlag - -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt - -> Code -- Continuation - -> Code -maybeAltHeapCheck NoGC _ code = code -maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code - -saveVolatileVarsAndRegs - :: StgLiveVars -- Vars which should be made safe - -> FCode (CmmStmts, -- Assignments to do the saves - EndOfBlockInfo, -- sequel for the alts - Maybe VirtualSpOffset) -- Slot for current cost centre - -saveVolatileVarsAndRegs vars - = do { var_saves <- saveVolatileVars vars - ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre - ; eob_info <- getEndOfBlockInfo - ; returnFC (var_saves `plusStmts` cc_save, - eob_info, - maybe_cc_slot) } - - -saveVolatileVars :: StgLiveVars -- Vars which should be made safe - -> FCode CmmStmts -- Assignments to to the saves - -saveVolatileVars vars - = do { stmts_s <- mapFCs save_it (varSetElems vars) - ; return (foldr plusStmts noStmts stmts_s) } - where - save_it var - = do { v <- getCAddrModeIfVolatile var - ; case v of - Nothing -> return noStmts -- Non-volatile - Just vol_amode -> save_var var vol_amode -- Aha! It's volatile - } - - save_var var vol_amode - = do { slot <- allocPrimStack (idCgRep var) - ; rebindToStack var slot - ; sp_rel <- getSpRelOffset slot - ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) } -\end{code} - ---------------------------------------------------------------------------- - -When we save the current cost centre (which is done for lexical -scoping), we allocate a free stack location, and return (a)~the -virtual offset of the location, to pass on to the alternatives, and -(b)~the assignment to do the save (just as for @saveVolatileVars@). - -\begin{code} -saveCurrentCostCentre :: - FCode (Maybe VirtualSpOffset, -- Where we decide to store it - CmmStmts) -- Assignment to save it - -saveCurrentCostCentre - = do dflags <- getDynFlags - if not (gopt Opt_SccProfilingOn dflags) - then returnFC (Nothing, noStmts) - else do slot <- allocPrimStack PtrArg - sp_rel <- getSpRelOffset slot - returnFC (Just slot, - oneStmt (CmmStore sp_rel curCCS)) - --- Sometimes we don't free the slot containing the cost centre after restoring it --- (see CgLetNoEscape.cgLetNoEscapeBody). -restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code -restoreCurrentCostCentre Nothing _freeit = nopC -restoreCurrentCostCentre (Just slot) freeit - = do { dflags <- getDynFlags - ; sp_rel <- getSpRelOffset slot - ; whenC freeit (freeStackSlots [slot]) - ; stmtC (storeCurCCS (CmmLoad sp_rel (bWord dflags))) } -\end{code} - diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs deleted file mode 100644 index b5ce231856..0000000000 --- a/compiler/codeGen/CgClosure.lhs +++ /dev/null @@ -1,641 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgClosure]{Code generation for closures} - -This module provides the support code for @StgToAbstractC@ to deal -with {\em closures} on the RHSs of let(rec)s. See also -@CgCon@, which deals with constructors. - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgClosure ( cgTopRhsClosure, - cgStdRhsClosure, - cgRhsClosure, - emitBlackHoleCode, - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} CgExpr ( cgExpr ) - -import CgMonad -import CgBindery -import CgHeapery -import CgStackery -import CgProf -import CgTicky -import CgParallel -import CgInfoTbls -import CgCallConv -import CgUtils -import ClosureInfo -import SMRep -import OldCmm -import OldCmmUtils -import CLabel -import StgSyn -import CostCentre -import Id -import Name -import Module -import ListSetOps -import Util -import BasicTypes -import DynFlags -import Outputable -import FastString - -import Data.List -\end{code} - -%******************************************************** -%* * -\subsection[closures-no-free-vars]{Top-level closures} -%* * -%******************************************************** - -For closures bound at top level, allocate in static space. -They should have no free variables. - -\begin{code} -cgTopRhsClosure :: Id - -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo - -> UpdateFlag - -> [Id] -- Args - -> StgExpr - -> FCode (Id, CgIdInfo) - -cgTopRhsClosure id ccs binder_info upd_flag args body = do - { -- LAY OUT THE OBJECT - let name = idName id - ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; srt_info <- getSRTInfo - ; mod_name <- getModuleName - ; dflags <- getDynFlags - ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr - closure_label = mkLocalClosureLabel name $ idCafInfo id - cg_id_info = stableIdInfo dflags id (mkLblExpr closure_label) lf_info - closure_rep = mkStaticClosureFields dflags closure_info ccs True [] - - -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) - ; emitDataLits closure_label closure_rep - ; forkClosureBody (closureCodeBody binder_info closure_info - ccs args body) - - ; returnFC (id, cg_id_info) } -\end{code} - -%******************************************************** -%* * -\subsection[non-top-level-closures]{Non top-level closures} -%* * -%******************************************************** - -For closures with free vars, allocate in heap. - -\begin{code} -cgStdRhsClosure - :: Id - -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo - -> [Id] -- Free vars - -> [Id] -- Args - -> StgExpr - -> LambdaFormInfo - -> [StgArg] -- payload - -> FCode (Id, CgIdInfo) - -cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload - = do -- AHA! A STANDARD-FORM THUNK - { -- LAY OUT THE OBJECT - amodes <- getArgAmodes payload - ; mod_name <- getModuleName - ; dflags <- getDynFlags - ; let (tot_wds, ptr_wds, amodes_w_offsets) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes - - descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds - NoC_SRT -- No SRT for a std-form closure - descr - --- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - - -- BUILD THE OBJECT - ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets - - -- RETURN - ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } -\end{code} - -Here's the general case. - -\begin{code} -cgRhsClosure :: Id - -> CostCentreStack -- Optional cost centre annotation - -> StgBinderInfo - -> [Id] -- Free vars - -> UpdateFlag - -> [Id] -- Args - -> StgExpr - -> FCode (Id, CgIdInfo) - -cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do - { -- LAY OUT THE OBJECT - -- If the binder is itself a free variable, then don't store - -- it in the closure. Instead, just bind it to Node on entry. - -- NB we can be sure that Node will point to it, because we - -- havn't told mkClosureLFInfo about this; so if the binder - -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* - -- stored in the closure itself, so it will make sure that - -- Node points to it... - let - name = idName bndr - bndr_is_a_fv = bndr `elem` fvs - reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] - | otherwise = fvs - - ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args - ; fv_infos <- mapFCs getCgIdInfo reduced_fvs - ; srt_info <- getSRTInfo - ; mod_name <- getModuleName - ; dflags <- getDynFlags - ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] - (tot_wds, ptr_wds, bind_details) - = mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos) - - add_rep info = (cgIdInfoArgRep info, info) - - descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo dflags False -- Not static - bndr lf_info tot_wds ptr_wds - srt_info descr - - -- BUILD ITS INFO TABLE AND CODE - ; forkClosureBody (do - { -- Bind the fvs - let - -- A function closure pointer may be tagged, so we - -- must take it into account when accessing the free variables. - mbtag = tagForArity dflags (length args) - bind_fv (info, offset) - | Just tag <- mbtag - = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag - | otherwise - = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info) - ; mapCs bind_fv bind_details - - -- Bind the binder itself, if it is a free var - ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info) - - -- Compile the body - ; closureCodeBody bndr_info closure_info cc args body }) - - -- BUILD THE OBJECT - ; let - to_amode (info, offset) = do { amode <- idInfoToAmode info - ; return (amode, offset) } --- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; amodes_w_offsets <- mapFCs to_amode bind_details - ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets - - -- RETURN - ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } - - -mkClosureLFInfo :: Id -- The binder - -> TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> FCode LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top fvs upd_flag) - | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top fvs args arg_descr) } -\end{code} - - -%************************************************************************ -%* * -\subsection[code-for-closures]{The code for closures} -%* * -%************************************************************************ - -\begin{code} -closureCodeBody :: StgBinderInfo - -> ClosureInfo -- Lots of information about this closure - -> CostCentreStack -- Optional cost centre attached to closure - -> [Id] - -> StgExpr - -> Code -\end{code} - -There are two main cases for the code for closures. If there are {\em -no arguments}, then the closure is a thunk, and not in normal form. -So it should set up an update frame (if it is shared). -NB: Thunks cannot have a primitive type! - -\begin{code} -closureCodeBody _binder_info cl_info _cc [{- No args i.e. thunk -}] body = do - { body_absC <- getCgStmts $ do - { tickyEnterThunk cl_info - ; ldvEnterClosure cl_info -- NB: Node always points when profiling - ; thunkWrapper cl_info $ do - -- We only enter cc after setting up update so - -- that cc of enclosing scope will be recorded - -- in the update frame - { enterCostCentreThunk (CmmReg nodeReg) - ; cgExpr body } - } - - ; emitClosureCodeAndInfoTable cl_info [] body_absC } -\end{code} - -If there is /at least one argument/, then this closure is in -normal form, so there is no need to set up an update frame. - -The Macros for GrAnSim are produced at the beginning of the -argSatisfactionCheck (by calling fetchAndReschedule). There info if -Node points to closure is available. -- HWL - -\begin{code} -closureCodeBody _binder_info cl_info cc args body - = ASSERT( length args > 0 ) - do { - dflags <- getDynFlags - -- Get the current virtual Sp (it might not be zero, - -- eg. if we're compiling a let-no-escape). - ; vSp <- getVirtSp - ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args) - (sp_top, stk_args) = mkVirtStkOffsets dflags vSp other_args - - -- Allocate the global ticky counter - ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) - ; emitTickyCounter cl_info args sp_top - - -- ...and establish the ticky-counter - -- label for this block - ; setTickyCtrLabel ticky_ctr_lbl $ do - - -- Emit the slow-entry code - { dflags <- getDynFlags - ; reg_save_code <- mkSlowEntryCode dflags cl_info reg_args - - -- Emit the main entry code - ; blks <- forkProc $ - mkFunEntryCode cl_info cc reg_args stk_args - sp_top reg_save_code body - ; emitClosureCodeAndInfoTable cl_info [] blks - }} - - - -mkFunEntryCode :: ClosureInfo - -> CostCentreStack - -> [(Id,GlobalReg)] -- Args in regs - -> [(Id,VirtualSpOffset)] -- Args on stack - -> VirtualSpOffset -- Last allocated word on stack - -> CmmStmts -- Register-save code in case of GC - -> StgExpr - -> Code --- The main entry code for the closure -mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do - { -- Bind args to regs/stack as appropriate, - -- and record expected position of sps - ; bindArgsToRegs reg_args - ; bindArgsToStack stk_args - ; setRealAndVirtualSp sp_top - - -- Do the business - ; funWrapper cl_info reg_args reg_save_code $ do - { dflags <- getDynFlags - ; tickyEnterFun cl_info - ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , mkIntExpr dflags (funTag dflags cl_info) ]) - (node : map snd reg_args) -- live regs - - ; cgExpr body } - } -\end{code} - -The "slow entry" code for a function. This entry point takes its -arguments on the stack. It loads the arguments into registers -according to the calling convention, and jumps to the function's -normal entry point. The function's closure is assumed to be in -R1/node. - -The slow entry point is used in two places: - - (a) unknown calls: eg. stg_PAP_entry - (b) returning from a heap-check failure - -\begin{code} -mkSlowEntryCode :: DynFlags -> ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts --- If this function doesn't have a specialised ArgDescr, we need --- to generate the function's arg bitmap, slow-entry code, and --- register-save code for the heap-check failure --- Here, we emit the slow-entry code, and --- return the register-save assignments -mkSlowEntryCode dflags cl_info reg_args - | Just (_, ArgGen _) <- closureFunInfo cl_info - = do { emitSimpleProc slow_lbl (emitStmts load_stmts) - ; return save_stmts } - | otherwise = return noStmts - where - name = closureName cl_info - has_caf_refs = clHasCafRefs cl_info - slow_lbl = mkSlowEntryLabel name has_caf_refs - - load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] - save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts - - reps_w_regs :: [(CgRep,GlobalReg)] - reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] - (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off)) - 0 reps_w_regs - - - load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets - mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) - (CmmLoad (cmmRegOffW dflags spReg offset) - (argMachRep dflags rep)) - - save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg ) - CmmStore (cmmRegOffW dflags spReg offset) - (CmmReg (CmmGlobal reg)) - - stk_adj_pop = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset)) - live_regs = Just $ map snd reps_w_regs - jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs -\end{code} - - -%************************************************************************ -%* * -\subsubsection[closure-code-wrappers]{Wrappers around closure code} -%* * -%************************************************************************ - -\begin{code} -thunkWrapper:: ClosureInfo -> Code -> Code -thunkWrapper closure_info thunk_code = do - { dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info) - - -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node - -- (we prefer fetchAndReschedule-style context switches to yield ones) - ; if node_points - then granFetchAndReschedule [] node_points - else granYield [] node_points - - -- Stack and/or heap checks - ; thunkEntryChecks closure_info $ do - { - -- Overwrite with black hole if necessary - ; whenC (blackHoleOnEntry closure_info && node_points) - (blackHoleIt closure_info) - ; setupUpdate closure_info thunk_code } - -- setupUpdate *encloses* the thunk_code - } - -funWrapper :: ClosureInfo -- Closure whose code body this is - -> [(Id,GlobalReg)] -- List of argument registers (if any) - -> CmmStmts -- reg saves for the heap check failure - -> Code -- Body of function being compiled - -> Code -funWrapper closure_info arg_regs reg_save_code fun_body = do - { dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info) - live = Just $ map snd arg_regs - - {- - -- Debugging: check that R1 has the correct tag - ; let tag = funTag closure_info - ; whenC (tag /= 0 && node_points) $ do - l <- newLabelC - stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), - mkIntExpr dflags tag)]) l) - stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0)) - labelC l - -} - - -- Enter for Ldv profiling - ; whenC node_points (ldvEnterClosure closure_info) - - -- GranSim yeild poin - ; granYield arg_regs node_points - - -- Heap and/or stack checks wrap the function body - ; funEntryChecks closure_info reg_save_code live fun_body - } -\end{code} - - -%************************************************************************ -%* * -\subsubsubsection[update-and-BHs]{Update and black-hole wrappers} -%* * -%************************************************************************ - - -\begin{code} -blackHoleIt :: ClosureInfo -> Code --- Only called for closures with no args --- Node points to the closure -blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) - -emitBlackHoleCode :: Bool -> Code -emitBlackHoleCode is_single_entry = do - dflags <- getDynFlags - - -- Eager blackholing is normally disabled, but can be turned on with - -- -feager-blackholing. When it is on, we replace the info pointer - -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - - -- If we wanted to do eager blackholing with slop filling, we'd need - -- to do it at the *end* of a basic block, otherwise we overwrite - -- the free variables in the thunk that we still need. We have a - -- patch for this from Andy Cheadle, but not incorporated yet. --SDM - -- [6/2004] - -- - -- Previously, eager blackholing was enabled when ticky-ticky was - -- on. But it didn't work, and it wasn't strictly necessary to bring - -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is - -- unconditionally disabled. -- krc 1/2007 - - -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, - -- because emitBlackHoleCode is called from CmmParse. - - let eager_blackholing = not (gopt Opt_SccProfilingOn dflags) - && gopt Opt_EagerBlackHoling dflags - -- Profiling needs slop filling (to support LDV - -- profiling), so currently eager blackholing doesn't - -- work with profiling. - - whenC eager_blackholing $ do - tickyBlackHole (not is_single_entry) - stmtsC [ - CmmStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) - (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, - CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) - ] -\end{code} - -\begin{code} -setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args - -- Nota Bene: this function does not change Node (even if it's a CAF), - -- so that the cost centre in the original closure can still be - -- extracted by a subsequent enterCostCentre -setupUpdate closure_info code - | closureReEntrant closure_info - = code - - | not (isStaticClosure closure_info) - = do - if not (closureUpdReqd closure_info) - then do tickyUpdateFrameOmitted; code - else do - tickyPushUpdateFrame - dflags <- getDynFlags - if blackHoleOnEntry closure_info && - not (gopt Opt_SccProfilingOn dflags) && - gopt Opt_EagerBlackHoling dflags - then pushBHUpdateFrame (CmmReg nodeReg) code - else pushUpdateFrame (CmmReg nodeReg) code - - | otherwise -- A static closure - = do { tickyUpdateBhCaf closure_info - - ; if closureUpdReqd closure_info - then do -- Blackhole the (updatable) CAF: - { upd_closure <- link_caf closure_info True - ; pushBHUpdateFrame upd_closure code } - else do - { -- krc: removed some ticky-related code here. - ; tickyUpdateFrameOmitted - ; code } - } - - ------------------------------------------------------------------------------ --- Entering a CAF --- --- When a CAF is first entered, it creates a black hole in the heap, --- and updates itself with an indirection to this new black hole. --- --- We update the CAF with an indirection to a newly-allocated black --- hole in the heap. We also set the blocking queue on the newly --- allocated black hole to be empty. --- --- Why do we make a black hole in the heap when we enter a CAF? --- --- - for a generational garbage collector, which needs a fast --- test for whether an updatee is in an old generation or not --- --- - for the parallel system, which can implement updates more --- easily if the updatee is always in the heap. (allegedly). --- --- When debugging, we maintain a separate CAF list so we can tell when --- a CAF has been garbage collected. - --- newCAF must be called before the itbl ptr is overwritten, since --- newCAF records the old itbl ptr in order to do CAF reverting --- (which Hugs needs to do in order that combined mode works right.) --- - --- ToDo [Feb 04] This entire link_caf nonsense could all be moved --- into the "newCAF" RTS procedure, which we call anyway, including --- the allocation of the black-hole indirection closure. --- That way, code size would fall, the CAF-handling code would --- be closer together, and the compiler wouldn't need to know --- about off_indirectee etc. - -link_caf :: ClosureInfo - -> Bool -- True <=> updatable, False <=> single-entry - -> FCode CmmExpr -- Returns amode for closure to be updated --- To update a CAF we must allocate a black hole, link the CAF onto the --- CAF list, then update the CAF to point to the fresh black hole. --- This function returns the address of the black hole, so it can be --- updated with the new value when available. The reason for all of this --- is that we only want to update dynamic heap objects, not static ones, --- so that generational GC is easier. -link_caf cl_info _is_upd = do - { dflags <- getDynFlags - -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom dflags (CmmReg nodeReg) - blame_cc = use_cc - tso = CmmReg (CmmGlobal CurrentTSO) - ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc - [(tso, fixedHdrSize dflags)] - ; hp_rel <- getHpRelOffset hp_offset - - -- Call the RTS function newCAF to add the CAF to the CafList - -- so that the garbage collector can find them - -- This must be done *before* the info table pointer is overwritten, - -- because the old info table ptr is needed for reversion - ; ret <- newTemp (bWord dflags) - ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF") - [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, - CmmHinted (CmmReg nodeReg) AddrHint, - CmmHinted hp_rel AddrHint ] - (Just [node]) - -- node is live, so save it. - - -- see Note [atomic CAF entry] in rts/sm/Storage.c - ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $ - -- re-enter R1. Doing this directly is slightly dodgy; we're - -- assuming lots of things, like the stack pointer hasn't - -- moved since we entered the CAF. - let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) in - stmtC (CmmJump target $ Just [node]) - - ; returnFC hp_rel } - where - bh_cl_info :: ClosureInfo - bh_cl_info = cafBlackHoleClosureInfo cl_info -\end{code} - - -%************************************************************************ -%* * -\subsection[CgClosure-Description]{Profiling Closure Description.} -%* * -%************************************************************************ - -For "global" data constructors the description is simply occurrence -name of the data constructor itself. Otherwise it is determined by -@closureDescription@ from the let binding information. - -\begin{code} -closureDescription :: DynFlags - -> Module -- Module - -> Name -- Id of closure binding - -> String - -- Not called for StgRhsCon which have global info tables built in - -- CgConTbls.lhs with a description generated from the data constructor -closureDescription dflags mod_name name - = showSDocDumpOneLine dflags (char '<' <> - (if isExternalName name - then ppr name -- ppr will include the module name prefix - else pprModule mod_name <> char '.' <> ppr name) <> - char '>') - -- showSDocDumpOneLine, because we want to see the unique on the Name. -\end{code} - diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs deleted file mode 100644 index abb280ff11..0000000000 --- a/compiler/codeGen/CgCon.lhs +++ /dev/null @@ -1,490 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -\section[CgCon]{Code generation for constructors} - -This module provides the support code for @StgToAbstractC@ to deal -with {\em constructors} on the RHSs of let(rec)s. See also -@CgClosure@, which deals with closures. - -\begin{code} -module CgCon ( - cgTopRhsCon, buildDynCon, - bindConArgs, bindUnboxedTupleComponents, - cgReturnDataCon, - cgTyCon - ) where - -#include "HsVersions.h" - -import CgMonad -import StgSyn - -import CgBindery -import CgStackery -import CgUtils -import CgCallConv -import CgHeapery -import CgTailCall -import CgProf -import CgTicky -import CgInfoTbls -import CLabel -import ClosureInfo -import OldCmmUtils -import OldCmm -import SMRep -import CostCentre -import TyCon -import DataCon -import Id -import IdInfo -import Type -import PrelInfo -import Outputable -import ListSetOps -import Util -import Module -import DynFlags -import FastString -import Platform - -import Control.Monad -\end{code} - - -%************************************************************************ -%* * -\subsection[toplevel-constructors]{Top-level constructors} -%* * -%************************************************************************ - -\begin{code} -cgTopRhsCon :: Id -- Name of thing bound to this RHS - -> DataCon -- Id - -> [StgArg] -- Args - -> FCode (Id, CgIdInfo) -cgTopRhsCon id con args - = do { dflags <- getDynFlags - ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ - -- Windows DLLs have a problem with static cross-DLL refs. - ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () - - -- LAY IT OUT - ; amodes <- getArgAmodes args - - ; let - name = idName id - lf_info = mkConLFInfo con - closure_label = mkClosureLabel name $ idCafInfo id - caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes - closure_rep = mkStaticClosureFields - dflags - closure_info - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - - payload = map get_lit amodes_w_offsets - get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (ppr other) - -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs - -- NB2: all the amodes should be Lits! - - -- BUILD THE OBJECT - ; emitDataLits closure_label closure_rep - - -- RETURN - ; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) } -\end{code} - -%************************************************************************ -%* * -%* non-top-level constructors * -%* * -%************************************************************************ -\subsection[code-for-constructors]{The code for constructors} - -\begin{code} -buildDynCon :: Id -- Name of the thing to which this constr will - -- be bound - -> CostCentreStack -- Where to grab cost centre from; - -- current CCS if currentOrSubsumedCCS - -> DataCon -- The data constructor - -> [(CgRep,CmmExpr)] -- Its args - -> FCode CgIdInfo -- Return details about how to find it -buildDynCon binder ccs con args - = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder ccs con args - -buildDynCon' :: DynFlags - -> Platform - -> Id - -> CostCentreStack - -> DataCon - -> [(CgRep,CmmExpr)] - -> FCode CgIdInfo - --- We used to pass a boolean indicating whether all the --- args were of size zero, so we could use a static --- construtor; but I concluded that it just isn't worth it. --- Now I/O uses unboxed tuples there just aren't any constructors --- with all size-zero args. --- --- The reason for having a separate argument, rather than looking at --- the addr modes of the args is that we may be in a "knot", and --- premature looking at the args will cause the compiler to black-hole! -\end{code} - -First we deal with the case of zero-arity constructors. Now, they -will probably be unfolded, so we don't expect to see this case much, -if at all, but it does no harm, and sets the scene for characters. - -In the case of zero-arity constructors, or, more accurately, those -which have exclusively size-zero (VoidRep) args, we generate no code -at all. - -\begin{code} -buildDynCon' dflags _ binder _ con [] - = returnFC (taggedStableIdInfo dflags binder - (mkLblExpr (mkClosureLabel (dataConName con) - (idCafInfo binder))) - (mkConLFInfo con) - con) -\end{code} - -The following three paragraphs about @Char@-like and @Int@-like -closures are obsolete, but I don't understand the details well enough -to properly word them, sorry. I've changed the treatment of @Char@s to -be analogous to @Int@s: only a subset is preallocated, because @Char@ -has now 31 bits. Only literals are handled here. -- Qrczak - -Now for @Char@-like closures. We generate an assignment of the -address of the closure to a temporary. It would be possible simply to -generate no code, and record the addressing mode in the environment, -but we'd have to be careful if the argument wasn't a constant --- so -for simplicity we just always asssign to a temporary. - -Last special case: @Int@-like closures. We only special-case the -situation in which the argument is a literal in the range -@mIN_INTLIKE@..@mAX_INTLILKE@. NB: for @Char@-like closures we can -work with any old argument, but for @Int@-like ones the argument has -to be a literal. Reason: @Char@ like closures have an argument type -which is guaranteed in range. - -Because of this, we use can safely return an addressing mode. - -We don't support this optimisation when compiling into Windows DLLs yet -because they don't support cross package data references well. - -\begin{code} - - -buildDynCon' dflags platform binder _ con [arg_amode] - | maybeIntLikeCon con - , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) - , (_, CmmLit (CmmInt val _)) <- arg_amode - , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags - = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") - offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) - -- INTLIKE closures consist of a header and one word payload - intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) - ; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) } - -buildDynCon' dflags platform binder _ con [arg_amode] - | maybeCharLikeCon con - , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) - , (_, CmmLit (CmmInt val _)) <- arg_amode - , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") - offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) - -- CHARLIKE closures consist of a header and one word payload - charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) - ; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) } - -\end{code} - -Now the general case. - -\begin{code} -buildDynCon' dflags _ binder ccs con args - = do { - ; let - (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args - - ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) } - where - lf_info = mkConLFInfo con - - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = curCCS - | otherwise = panic "buildDynCon: non-current CCS not implemented" - - blame_cc = use_cc -- cost-centre on which to blame the alloc (same) -\end{code} - - -%************************************************************************ -%* * -%* constructor-related utility function: * -%* bindConArgs is called from cgAlt of a case * -%* * -%************************************************************************ -\subsection[constructor-utilities]{@bindConArgs@: constructor-related utility} - -@bindConArgs@ $con args$ augments the environment with bindings for the -binders $args$, assuming that we have just returned from a @case@ which -found a $con$. - -\begin{code} -bindConArgs :: DataCon -> [Id] -> Code -bindConArgs con args - = do dflags <- getDynFlags - let - -- The binding below forces the masking out of the tag bits - -- when accessing the constructor field. - bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con) - (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) - -- - ASSERT(not (isUnboxedTupleCon con)) return () - mapCs bind_arg args_w_offsets -\end{code} - -Unboxed tuples are handled slightly differently - the object is -returned in registers and on the stack instead of the heap. - -\begin{code} -bindUnboxedTupleComponents - :: [Id] -- Args - -> FCode ([(Id,GlobalReg)], -- Regs assigned - WordOff, -- Number of pointer stack slots - WordOff, -- Number of non-pointer stack slots - VirtualSpOffset) -- Offset of return address slot - -- (= realSP on entry) - -bindUnboxedTupleComponents args - = do { - dflags <- getDynFlags - - ; vsp <- getVirtSp - ; rsp <- getRealSp - - -- Assign as many components as possible to registers - ; let (reg_args, stk_args) = assignReturnRegs dflags (addIdReps args) - - -- Separate the rest of the args into pointers and non-pointers - (ptr_args, nptr_args) = separateByPtrFollowness stk_args - - -- Allocate the rest on the stack - -- The real SP points to the return address, above which any - -- leftover unboxed-tuple components will be allocated - (ptr_sp, ptr_offsets) = mkVirtStkOffsets dflags rsp ptr_args - (nptr_sp, nptr_offsets) = mkVirtStkOffsets dflags ptr_sp nptr_args - ptrs = ptr_sp - rsp - nptrs = nptr_sp - ptr_sp - - -- The stack pointer points to the last stack-allocated component - ; setRealAndVirtualSp nptr_sp - - -- We have just allocated slots starting at real SP + 1, and set the new - -- virtual SP to the topmost allocated slot. - -- If the virtual SP started *below* the real SP, we've just jumped over - -- some slots that won't be in the free-list, so put them there - -- This commonly happens because we've freed the return-address slot - -- (trimming back the virtual SP), but the real SP still points to that slot - ; freeStackSlots [vsp+1,vsp+2 .. rsp] - - ; bindArgsToRegs reg_args - ; bindArgsToStack ptr_offsets - ; bindArgsToStack nptr_offsets - - ; returnFC (reg_args, ptrs, nptrs, rsp) } -\end{code} - -%************************************************************************ -%* * - Actually generate code for a constructor return -%* * -%************************************************************************ - - -Note: it's the responsibility of the @cgReturnDataCon@ caller to be -sure the @amodes@ passed don't conflict with each other. -\begin{code} -cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code - -cgReturnDataCon con amodes = do - dflags <- getDynFlags - if isUnboxedTupleCon con then returnUnboxedTuple amodes - -- when profiling we can't shortcut here, we have to enter the closure - -- for it to be marked as "used" for LDV profiling. - else if gopt Opt_SccProfilingOn dflags then build_it_then (enter_it dflags) - else ASSERT( amodes `lengthIs` dataConRepRepArity con ) - do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo - ; case sequel of - CaseAlts _ (Just (alts, deflt_lbl)) bndr - -> -- Ho! We know the constructor so we can - -- go straight to the right alternative - case assocMaybe alts (dataConTagZ con) of { - Just join_lbl -> build_it_then (jump_to join_lbl); - Nothing - -- Special case! We're returning a constructor to the default case - -- of an enclosing case. For example: - -- - -- case (case e of (a,b) -> C a b) of - -- D x -> ... - -- y -> ...<returning here!>... - -- - -- In this case, - -- if the default is a non-bind-default (ie does not use y), - -- then we should simply jump to the default join point; - - | isDeadBinder bndr -> performReturn (jump_to deflt_lbl) - | otherwise -> build_it_then (jump_to deflt_lbl) } - - _otherwise -- The usual case - -> build_it_then $ emitReturnInstr node_live - } - where - node_live = Just [node] - enter_it dflags - = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)), - CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg) - node_live - ] - jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live - build_it_then return_code - = do { -- BUILD THE OBJECT IN THE HEAP - -- The first "con" says that the name bound to this - -- closure is "con", which is a bit of a fudge, but it only - -- affects profiling - - -- This Id is also used to get a unique for a - -- temporary variable, if the closure is a CHARLIKE. - -- funnily enough, this makes the unique always come - -- out as '54' :-) - tickyReturnNewCon (length amodes) - ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes - ; amode <- idInfoToAmode idinfo - ; checkedAbsC (CmmAssign nodeReg amode) - ; performReturn return_code } -\end{code} - - -%************************************************************************ -%* * - Generating static stuff for algebraic data types -%* * -%************************************************************************ - - [These comments are rather out of date] - -\begin{tabular}{lll} -Info tbls & Macro & Kind of constructor \\ -\hline -info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\ -info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\ -info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\ -info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\ -info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\ -\end{tabular} - -Possible info tables for constructor con: - -\begin{description} -\item[@_con_info@:] -Used for dynamically let(rec)-bound occurrences of -the constructor, and for updates. For constructors -which are int-like, char-like or nullary, when GC occurs, -the closure tries to get rid of itself. - -\item[@_static_info@:] -Static occurrences of the constructor -macro: @STATIC_INFO_TABLE@. -\end{description} - -For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure; -it's place is taken by the top level defn of the constructor. - -For charlike and intlike closures there is a fixed array of static -closures predeclared. - -\begin{code} -cgTyCon :: TyCon -> FCode CmmGroup -- each constructor gets a separate CmmGroup -cgTyCon tycon - = do { dflags <- getDynFlags - ; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) - - -- Generate a table of static closures for an enumeration type - -- Put the table after the data constructor decls, because the - -- datatype closure table (for enumeration types) - -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff - -- Note that the closure pointers are tagged. - - -- XXX comment says to put table after constructor decls, but - -- code appears to put it before --- NR 16 Aug 2007 - ; extra <- - if isEnumerationTyCon tycon then do - tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) - [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) - | con <- tyConDataCons tycon]) - return [tbl] - else - return [] - - ; return (concat (extra ++ constrs)) - } -\end{code} - -Generate the entry code, info tables, and (for niladic constructor) the -static closure, for a constructor. - -\begin{code} -cgDataCon :: DataCon -> Code -cgDataCon data_con - = do { dflags <- getDynFlags - -- Don't need any dynamic closure code for zero-arity constructors - - ; let - -- To allow the debuggers, interpreters, etc to cope with - -- static data structures (ie those built at compile - -- time), we take care that info-table contains the - -- information we need. - (static_cl_info, _) = - layOutStaticConstr dflags data_con arg_reps - - (dyn_cl_info, arg_things) = - layOutDynConstr dflags data_con arg_reps - - emit_info cl_info ticky_code - = do { code_blks <- getCgStmts the_code - ; emitClosureCodeAndInfoTable cl_info [] code_blks } - where - the_code = do { _ <- ticky_code - ; ldvEnter (CmmReg nodeReg) - ; body_code } - - arg_reps :: [(CgRep, UnaryType)] - arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] - - body_code = do { - -- NB: We don't set CC when entering data (WDP 94/06) - tickyReturnOldCon (length arg_things) - -- The case continuation code is expecting a tagged pointer - ; stmtC (CmmAssign nodeReg - (tagCons dflags data_con (CmmReg nodeReg))) - ; performReturn $ emitReturnInstr (Just []) } - -- noStmts: Ptr to thing already in Node - - ; whenC (not (isNullaryRepDataCon data_con)) - (emit_info dyn_cl_info tickyEnterDynCon) - - -- Dynamic-Closure first, to reduce forward references - ; emit_info static_cl_info tickyEnterStaticCon } -\end{code} diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs deleted file mode 100644 index 70fb600901..0000000000 --- a/compiler/codeGen/CgExpr.lhs +++ /dev/null @@ -1,496 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgExpr ( cgExpr ) where - -#include "HsVersions.h" - -import StgSyn -import CgMonad - -import CostCentre -import SMRep -import CoreSyn -import CgProf -import CgHeapery -import CgBindery -import CgCase -import CgClosure -import CgCon -import CgLetNoEscape -import CgTailCall -import CgInfoTbls -import CgForeignCall -import CgPrimOp -import CgHpc -import CgUtils -import ClosureInfo -import OldCmm -import OldCmmUtils -import VarSet -import Literal -import PrimOp -import Id -import TyCon -import Type -import Maybes -import ListSetOps -import BasicTypes -import Util -import DynFlags -import Outputable -\end{code} - -This module provides the support code for @StgToAbstractC@ to deal -with STG {\em expressions}. See also @CgClosure@, which deals -with closures, and @CgCon@, which deals with constructors. - -\begin{code} -cgExpr :: StgExpr -- input - -> Code -- output -\end{code} - -%******************************************************** -%* * -%* Tail calls * -%* * -%******************************************************** - -``Applications'' mean {\em tail calls}, a service provided by module -@CgTailCall@. This includes literals, which show up as -@(STGApp (StgLitArg 42) [])@. - -\begin{code} -cgExpr (StgApp fun args) = cgTailCall fun args -\end{code} - -%******************************************************** -%* * -%* STG ConApps (for inline versions) * -%* * -%******************************************************** - -\begin{code} -cgExpr (StgConApp con args) - = do { amodes <- getArgAmodes args - ; cgReturnDataCon con amodes } -\end{code} - -Literals are similar to constructors; they return by putting -themselves in an appropriate register and returning to the address on -top of the stack. - -\begin{code} -cgExpr (StgLit lit) - = do { cmm_lit <- cgLit lit - ; performPrimReturn rep (CmmLit cmm_lit) } - where - rep = (typeCgRep) (literalType lit) -\end{code} - - -%******************************************************** -%* * -%* PrimOps and foreign calls. -%* * -%******************************************************** - -NOTE about "safe" foreign calls: a safe foreign call is never compiled -inline in a case expression. When we see - - case (ccall ...) of { ... } - -We generate a proper return address for the alternatives and push the -stack frame before doing the call, so that in the event that the call -re-enters the RTS the stack is in a sane state. - -\begin{code} -cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do - dflags <- getDynFlags - {- - First, copy the args into temporaries. We're going to push - a return address right before doing the call, so the args - must be out of the way. - -} - reps_n_amodes <- getArgAmodes stg_args - let - -- Get the *non-void* args, and jiggle them with shimForeignCall - arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg) - | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, - nonVoidArg rep] - - arg_tmps <- sequence [ assignTemp arg - | (arg, _) <- arg_exprs] - let arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args) - {- - Now, allocate some result regs. - -} - (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty - ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $ - emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall - arg_hints emptyVarSet{-no live vars-} - --- tagToEnum# is special: we need to pull the constructor out of the table, --- and perform an appropriate return. - -cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) - = ASSERT(isEnumerationTyCon tycon) - do { dflags <- getDynFlags - ; (_rep,amode) <- getArgAmode arg - ; amode' <- assignTemp amode -- We're going to use it twice, - -- so save in a temp if non-trivial - ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) - ; performReturn $ emitReturnInstr (Just [node]) } - where - -- If you're reading this code in the attempt to figure - -- out why the compiler panic'ed here, it is probably because - -- you used tagToEnum# in a non-monomorphic setting, e.g., - -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# - -- That won't work. - tycon = tyConAppTyCon res_ty - - -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) - = cgTailCall a [] - -- seq# :: a -> State# -> (# State# , a #) - -- but the return convention for (# State#, a #) is exactly the same as - -- for just a, so we can implment seq# by - -- seq# a s ==> a - -cgExpr (StgOpApp (StgPrimOp primop) args res_ty) - | primOpOutOfLine primop - = tailCallPrimOp primop args - - | ReturnsPrim VoidRep <- result_info - = do cgPrimOp [] primop args emptyVarSet - -- ToDo: STG Live -- worried about this - performReturn $ emitReturnInstr (Just []) - - | ReturnsPrim rep <- result_info - = do dflags <- getDynFlags - res <- newTemp (typeCmmType dflags res_ty) - cgPrimOp [res] primop args emptyVarSet - performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res)) - - | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon - = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty - cgPrimOp regs primop args emptyVarSet{-no live vars-} - returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs)) - - | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon - -- c.f. cgExpr (...TagToEnumOp...) - = do dflags <- getDynFlags - tag_reg <- newTemp (bWord dflags) -- The tag is a word - cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg - (tagToClosure dflags tycon - (CmmReg (CmmLocal tag_reg)))) - -- ToDo: STG Live -- worried about this - performReturn $ emitReturnInstr (Just [node]) - where - result_info = getPrimOpResultInfo primop - -cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty) - = tailCallPrimCall primcall args -\end{code} - -%******************************************************** -%* * -%* Case expressions * -%* * -%******************************************************** -Case-expression conversion is complicated enough to have its own -module, @CgCase@. -\begin{code} - -cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts) - = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts -\end{code} - - -%******************************************************** -%* * -%* Let and letrec * -%* * -%******************************************************** -\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@} - -\begin{code} -cgExpr (StgLet (StgNonRec name rhs) expr) - = cgRhs name rhs `thenFC` \ (name, info) -> - addBindC name info `thenC` - cgExpr expr - -cgExpr (StgLet (StgRec pairs) expr) - = fixC (\ new_bindings -> addBindsC new_bindings `thenC` - listFCs [ cgRhs b e | (b,e) <- pairs ] - ) `thenFC` \ new_bindings -> - - addBindsC new_bindings `thenC` - cgExpr expr -\end{code} - -\begin{code} -cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) - = do { -- Figure out what volatile variables to save - ; nukeDeadBindings live_in_whole_let - ; (save_assts, rhs_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_rhss - - -- Save those variables right now! - ; emitStmts save_assts - - -- Produce code for the rhss - -- and add suitable bindings to the environment - ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info - maybe_cc_slot bindings - - -- Do the body - ; setEndOfBlockInfo rhs_eob_info (cgExpr body) } -\end{code} - - -%******************************************************** -%* * -%* SCC Expressions * -%* * -%******************************************************** - -SCC expressions are treated specially. They set the current cost -centre. - -\begin{code} -cgExpr (StgSCC cc tick push expr) = do emitSetCCC cc tick push; cgExpr expr -\end{code} - -%******************************************************** -%* * -%* Hpc Tick Boxes * -%* * -%******************************************************** - -\begin{code} -cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr -\end{code} - -%******************************************************** -%* * -%* Anything else * -%* * -%******************************************************** - -\begin{code} -cgExpr _ = panic "cgExpr" -\end{code} - -%******************************************************** -%* * -%* Non-top-level bindings * -%* * -%******************************************************** -\subsection[non-top-level-bindings]{Converting non-top-level bindings} - -We rely on the support code in @CgCon@ (to do constructors) and -in @CgClosure@ (to do closures). - -\begin{code} -cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) - -- the Id is passed along so a binding can be set up - -cgRhs name (StgRhsCon maybe_cc con args) - = do { amodes <- getArgAmodes args - ; idinfo <- buildDynCon name maybe_cc con amodes - ; returnFC (name, idinfo) } - -cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do dflags <- getDynFlags - setSRT srt $ mkRhsClosure dflags name cc bi fvs upd_flag args body -\end{code} - -mkRhsClosure looks for two special forms of the right-hand side: - a) selector thunks. - b) AP thunks - -If neither happens, it just calls mkClosureLFInfo. You might think -that mkClosureLFInfo should do all this, but it seems wrong for the -latter to look at the structure of an expression - -Selectors -~~~~~~~~~ -We look at the body of the closure to see if it's a selector---turgid, -but nothing deep. We are looking for a closure of {\em exactly} the -form: - -... = [the_fv] \ u [] -> - case the_fv of - con a_1 ... a_n -> a_i - - -\begin{code} -mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo - -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id - -> FCode (Id, CgIdInfo) -mkRhsClosure dflags bndr cc bi - [the_fv] -- Just one free var - upd_flag -- Updatable thunk - [] -- A thunk - body@(StgCase (StgApp scrutinee [{-no args-}]) - _ _ _ srt -- ignore uniq, etc. - (AlgAlt _) - [(DataAlt con, params, _use_mask, - (StgApp selectee [{-no args-}]))]) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough - = -- NOT TRUE: ASSERT(is_single_constructor) - -- The simplifier may have statically determined that the single alternative - -- is the only possible case and eliminated the others, even if there are - -- other constructors in the datatype. It's still ok to make a selector - -- thunk in this case, because we *know* which constructor the scrutinee - -- will evaluate to. - setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] - where - lf_info = mkSelectorLFInfo bndr offset_into_int - (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params) - -- Just want the layout - maybe_offset = assocMaybe params_w_offsets selectee - Just the_offset = maybe_offset - offset_into_int = the_offset - fixedHdrSize dflags -\end{code} - -Ap thunks -~~~~~~~~~ - -A more generic AP thunk of the form - - x = [ x_1...x_n ] \.. [] -> x_1 ... x_n - -A set of these is compiled statically into the RTS, so we just use -those. We could extend the idea to thunks where some of the x_i are -global ids (and hence not free variables), but this would entail -generating a larger thunk. It might be an option for non-optimising -compilation, though. - -We only generate an Ap thunk if all the free variables are pointers, -for semi-obvious reasons. - -\begin{code} -mkRhsClosure dflags bndr cc bi - fvs - upd_flag - [] -- No args; a thunk - body@(StgApp fun_id args) - - | args `lengthIs` (arity-1) - && all isFollowableArg (map idCgRep fvs) - && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE dflags - && not (gopt Opt_SccProfilingOn dflags) - -- not when profiling: we don't want to - -- lose information about this particular - -- thunk (e.g. its type) (#949) - - -- Ha! an Ap thunk - = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload - - where - lf_info = mkApLFInfo bndr upd_flag arity - -- the payload has to be in the correct order, hence we can't - -- just use the fvs. - payload = StgVarArg fun_id : args - arity = length fvs -\end{code} - -The default case -~~~~~~~~~~~~~~~~ -\begin{code} -mkRhsClosure _ bndr cc bi fvs upd_flag args body - = cgRhsClosure bndr cc bi fvs upd_flag args body -\end{code} - - -%******************************************************** -%* * -%* Let-no-escape bindings -%* * -%******************************************************** -\begin{code} -cgLetNoEscapeBindings :: StgLiveVars -> EndOfBlockInfo - -> Maybe VirtualSpOffset -> GenStgBinding Id Id - -> Code -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot - (StgNonRec binder rhs) - = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info - maybe_cc_slot - NonRecursive binder rhs - ; addBindC binder info } - -cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) - = do { new_bindings <- fixC (\ new_bindings -> do - { addBindsC new_bindings - ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss - rhs_eob_info maybe_cc_slot Recursive b e - | (b,e) <- pairs ] }) - - ; addBindsC new_bindings } - where - -- We add the binders to the live-in-rhss set so that we don't - -- delete the bindings for the binder from the environment! - full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,_) <- pairs]) - -cgLetNoEscapeRhs - :: StgLiveVars -- Live in rhss - -> EndOfBlockInfo - -> Maybe VirtualSpOffset - -> RecFlag - -> Id - -> StgRhs - -> FCode (Id, CgIdInfo) - -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsClosure cc bi _ _upd_flag srt args body) - = -- We could check the update flag, but currently we don't switch it off - -- for let-no-escaped things, so we omit the check too! - -- case upd_flag of - -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update! - -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body - setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info - maybe_cc_slot rec args body - --- For a constructor RHS we want to generate a single chunk of code which --- can be jumped to from many places, which will return the constructor. --- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! -cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder - (StgRhsCon cc con args) - = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} - full_live_in_rhss rhs_eob_info maybe_cc_slot rec - [] --No args; the binder is data structure, not a function - (StgConApp con args) -\end{code} - -Little helper for primitives that return unboxed tuples. - -\begin{code} -newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) -newUnboxedTupleRegs res_ty = do - dflags <- getDynFlags - let - UbxTupleRep ty_args = repType res_ty - (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, - let rep = typeCgRep ty, - nonVoidArg rep ] - make_new_temp rep = newTemp (argMachRep dflags rep) - regs <- mapM make_new_temp reps - return (reps,regs,hints) -\end{code} diff --git a/compiler/codeGen/CgExpr.lhs-boot b/compiler/codeGen/CgExpr.lhs-boot deleted file mode 100644 index 29cdc3a605..0000000000 --- a/compiler/codeGen/CgExpr.lhs-boot +++ /dev/null @@ -1,7 +0,0 @@ -\begin{code} -module CgExpr where -import StgSyn( StgExpr ) -import CgMonad( Code ) - -cgExpr :: StgExpr -> Code -\end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs deleted file mode 100644 index b0e6516f2d..0000000000 --- a/compiler/codeGen/CgForeignCall.hs +++ /dev/null @@ -1,322 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for foreign calls. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CgForeignCall ( - cgForeignCall, - emitForeignCall, - emitForeignCall', - shimForeignCallArg, - emitSaveThreadState, -- will be needed by the Cmm parser - emitLoadThreadState, -- ditto - emitCloseNursery, - emitOpenNursery, - ) where - -import StgSyn -import CgProf -import CgBindery -import CgMonad -import CgUtils -import Type -import TysPrim -import ClosureInfo( nonVoidArg ) -import CLabel -import OldCmm -import OldCmmUtils -import SMRep -import ForeignCall -import DynFlags -import Outputable -import Module -import FastString -import BasicTypes - -import Control.Monad - --- ----------------------------------------------------------------------------- --- Code generation for Foreign Calls - -cgForeignCall - :: [HintedCmmFormal] -- where to put the results - -> ForeignCall -- the op - -> [StgArg] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code -cgForeignCall results fcall stg_args live - = do - reps_n_amodes <- getArgAmodes stg_args - dflags <- getDynFlags - let - -- Get the *non-void* args, and jiggle them with shimForeignCall - arg_exprs = [ shimForeignCallArg dflags stg_arg expr - | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, - nonVoidArg rep] - - arg_hints = zipWith CmmHinted - arg_exprs (map (typeForeignHint.stgArgType) stg_args) - emitForeignCall results fcall arg_hints live - - -emitForeignCall - :: [HintedCmmFormal] -- where to put the results - -> ForeignCall -- the op - -> [CmmHinted CmmExpr] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code - -emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do - dflags <- getDynFlags - let (call_args, cmm_target) - = case target of - StaticTarget _ _ False -> - panic "emitForeignCall: unexpected FFI value import" - -- If the packageId is Nothing then the label is taken to be in the - -- package currently being compiled. - StaticTarget lbl mPkgId True - -> let labelSource - = case mPkgId of - Nothing -> ForeignLabelInThisPackage - Just pkgId -> ForeignLabelInPackage pkgId - in ( args - , CmmLit (CmmLabel - (mkForeignLabel lbl call_size labelSource IsFunction))) - - -- A label imported with "foreign import ccall "dynamic" ..." - -- Note: "dynamic" here doesn't mean "dynamic library". - -- Read the FFI spec for details. - DynamicTarget -> case args of - (CmmHinted fn _):rest -> (rest, fn) - [] -> panic "emitForeignCall: DynamicTarget []" - - -- in the stdcall calling convention, the symbol needs @size appended - -- to it, where size is the total number of bytes of arguments. We - -- attach this info to the CLabel here, and the CLabel pretty printer - -- will generate the suffix when the label is printed. - call_size - | StdCallConv <- cconv = Just (sum (map (arg_size . cmmExprType dflags . hintlessCmm) args)) - | otherwise = Nothing - - -- ToDo: this might not be correct for 64-bit API - arg_size rep = max (widthInBytes (typeWidth rep)) (wORD_SIZE dflags) - vols <- getVolatileRegs live - srt <- getSRTInfo - emitForeignCall' safety results - (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn - - --- alternative entry point, used by CmmParse --- the new code generator has utility function emitCCall and emitPrimCall --- which should be used instead of this (the equivalent emitForeignCall --- is not presently exported.) -emitForeignCall' - :: Safety - -> [HintedCmmFormal] -- where to put the results - -> CmmCallTarget -- the op - -> [CmmHinted CmmExpr] -- arguments - -> Maybe [GlobalReg] -- live vars, in case we need to save them - -> C_SRT -- the SRT of the calls continuation - -> CmmReturnInfo - -> Code -emitForeignCall' safety results target args vols _srt ret - | not (playSafe safety) = do - dflags <- getDynFlags - temp_args <- load_args_into_temps args - let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols - let caller_load' = if ret == CmmNeverReturns then [] else caller_load - stmtsC caller_save - stmtC (CmmCall target results temp_args ret) - stmtsC caller_load' - - | otherwise = do - dflags <- getDynFlags - -- Both 'id' and 'new_base' are GCKindNonPtr because they're - -- RTS only objects and are not subject to garbage collection - id <- newTemp (bWord dflags) - new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) - temp_args <- load_args_into_temps args - temp_target <- load_target_into_temp target - let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols - emitSaveThreadState - stmtsC caller_save - -- The CmmUnsafe arguments are only correct because this part - -- of the code hasn't been moved into the CPS pass yet. - -- Once that happens, this function will just emit a (CmmSafe srt) call, - -- and the CPS will be the one to convert that - -- to this sequence of three CmmUnsafe calls. - stmtC (CmmCall (CmmCallee suspendThread CCallConv) - [ CmmHinted id AddrHint ] - [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint - , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint] - ret) - stmtC (CmmCall temp_target results temp_args ret) - stmtC (CmmCall (CmmCallee resumeThread CCallConv) - [ CmmHinted new_base AddrHint ] - [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ] - ret) - -- Assign the result to BaseReg: we - -- might now have a different Capability! - stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) - stmtsC caller_load - emitLoadThreadState - -suspendThread, resumeThread :: CmmExpr -suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) - - --- we might need to load arguments into temporaries before --- making the call, because certain global registers might --- overlap with registers that the C calling convention uses --- for passing arguments. --- --- This is a HACK; really it should be done in the back end, but --- it's easier to generate the temporaries here. -load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr] -load_args_into_temps = mapM arg_assign_temp - where arg_assign_temp (CmmHinted e hint) = do - tmp <- maybe_assign_temp e - return (CmmHinted tmp hint) - -load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget -load_target_into_temp (CmmCallee expr conv) = do - tmp <- maybe_assign_temp expr - return (CmmCallee tmp conv) -load_target_into_temp other_target = - return other_target - -maybe_assign_temp :: CmmExpr -> FCode CmmExpr -maybe_assign_temp e - | hasNoGlobalRegs e = return e - | otherwise = do - dflags <- getDynFlags - -- don't use assignTemp, it uses its own notion of "trivial" - -- expressions, which are wrong here. - -- this is a NonPtr because it only duplicates an existing - reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW - stmtC (CmmAssign (CmmLocal reg) e) - return (CmmReg (CmmLocal reg)) - --- ----------------------------------------------------------------------------- --- Save/restore the thread state in the TSO - --- This stuff can't be done in suspendThread/resumeThread, because it --- refers to global registers which aren't available in the C world. - -emitSaveThreadState :: Code -emitSaveThreadState = do - dflags <- getDynFlags - -- CurrentTSO->stackobj->sp = Sp; - stmtC $ CmmStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) - (stack_SP dflags)) stgSp - emitCloseNursery - -- and save the current cost centre stack in the TSO when profiling: - when (gopt Opt_SccProfilingOn dflags) $ - stmtC (CmmStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS) - - -- CurrentNursery->free = Hp+1; -emitCloseNursery :: Code -emitCloseNursery = do dflags <- getDynFlags - stmtC $ CmmStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) - -emitLoadThreadState :: Code -emitLoadThreadState = do - dflags <- getDynFlags - tso <- newTemp (bWord dflags) -- TODO FIXME NOW - stack <- newTemp (bWord dflags) -- TODO FIXME NOW - stmtsC [ - -- tso = CurrentTSO - CmmAssign (CmmLocal tso) stgCurrentTSO, - -- stack = tso->stackobj - CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), - -- Sp = stack->sp; - CmmAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) - (bWord dflags)), - -- SpLim = stack->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), - -- HpAlloc = 0; - -- HpAlloc is assumed to be set to non-zero only by a failed - -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - CmmAssign hpAlloc (CmmLit (zeroCLit dflags)) - ] - emitOpenNursery - -- and load the current cost centre stack from the TSO when profiling: - when (gopt Opt_SccProfilingOn dflags) $ - stmtC $ storeCurCCS $ - CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (bWord dflags) - -emitOpenNursery :: Code -emitOpenNursery = - do dflags <- getDynFlags - stmtsC [ - -- Hp = CurrentNursery->free - 1; - CmmAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (gcWord dflags)) (-1)), - - -- HpLim = CurrentNursery->start + - -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - CmmAssign hpLim - (cmmOffsetExpr dflags - (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) - (cmmOffset dflags - (CmmMachOp (mo_wordMul dflags) [ - CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) - [CmmLoad (nursery_bdescr_blocks dflags) b32], - mkIntExpr dflags (bLOCK_SIZE dflags) - ]) - (-1) - ) - ) - ] - -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr -nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) - -tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) -tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) -stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) -stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) - -closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags - -stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr -stgSp = CmmReg sp -stgHp = CmmReg hp -stgCurrentTSO = CmmReg currentTSO -stgCurrentNursery = CmmReg currentNursery - -sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg -sp = CmmGlobal Sp -spLim = CmmGlobal SpLim -hp = CmmGlobal Hp -hpLim = CmmGlobal HpLim -currentTSO = CmmGlobal CurrentTSO -currentNursery = CmmGlobal CurrentNursery -hpAlloc = CmmGlobal HpAlloc - --- ----------------------------------------------------------------------------- --- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#/Array# we pass the --- address of the actual array, not the address of the heap object. - -shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr -shimForeignCallArg dflags arg expr - | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) - - | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB dflags expr (arrWordsHdrSize dflags) - - | otherwise = expr - where - -- should be a tycon app, since this is a foreign call - UnaryRep rep_ty = repType (stgArgType arg) - tycon = tyConAppTyCon rep_ty diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs deleted file mode 100644 index 8cff77381d..0000000000 --- a/compiler/codeGen/CgHeapery.lhs +++ /dev/null @@ -1,642 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgHeapery]{Heap management functions} - -\begin{code} -module CgHeapery ( - initHeapUsage, getVirtHp, setVirtHp, setRealHp, - getHpRelOffset, hpRel, - - funEntryChecks, thunkEntryChecks, - altHeapCheck, unbxTupleHeapCheck, - hpChkGen, hpChkNodePointsAssignSp0, - stkChkGen, stkChkNodePoints, - - layOutDynConstr, layOutStaticConstr, - mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure, - - allocDynClosure, emitSetDynHdr - ) where - -#include "HsVersions.h" - -import StgSyn -import CLabel -import CgUtils -import CgMonad -import CgProf -import CgTicky -import CgParallel -import CgStackery -import CgCallConv -import ClosureInfo -import SMRep - -import OldCmm -import OldCmmUtils -import Id -import DataCon -import TyCon -import CostCentre -import Util -import Module -import Outputable -import DynFlags -import FastString - -import Data.List -import Data.Maybe (fromMaybe) -\end{code} - - -%************************************************************************ -%* * -\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage} -%* * -%************************************************************************ - -The heap always grows upwards, so hpRel is easy - -\begin{code} -hpRel :: VirtualHpOffset -- virtual offset of Hp - -> VirtualHpOffset -- virtual offset of The Thing - -> WordOff -- integer word offset -hpRel hp off = off - hp -\end{code} - -@initHeapUsage@ applies a function to the amount of heap that it uses. -It initialises the heap usage to zeros, and passes on an unchanged -heap usage. - -It is usually a prelude to performing a GC check, so everything must -be in a tidy and consistent state. - -rje: Note the slightly suble fixed point behaviour needed here - -\begin{code} -initHeapUsage :: (VirtualHpOffset -> Code) -> Code -initHeapUsage fcode - = do { orig_hp_usage <- getHpUsage - ; setHpUsage initHpUsage - ; fixC_(\heap_usage2 -> do - { fcode (heapHWM heap_usage2) - ; getHpUsage }) - ; setHpUsage orig_hp_usage } - -setVirtHp :: VirtualHpOffset -> Code -setVirtHp new_virtHp - = do { hp_usage <- getHpUsage - ; setHpUsage (hp_usage {virtHp = new_virtHp}) } - -getVirtHp :: FCode VirtualHpOffset -getVirtHp - = do { hp_usage <- getHpUsage - ; return (virtHp hp_usage) } - -setRealHp :: VirtualHpOffset -> Code -setRealHp new_realHp - = do { hp_usage <- getHpUsage - ; setHpUsage (hp_usage {realHp = new_realHp}) } - -getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr -getHpRelOffset virtual_offset - = do { dflags <- getDynFlags - ; hp_usg <- getHpUsage - ; return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) } -\end{code} - - -%************************************************************************ -%* * - Layout of heap objects -%* * -%************************************************************************ - -\begin{code} -layOutDynConstr, layOutStaticConstr - :: DynFlags - -> DataCon - -> [(CgRep,a)] - -> (ClosureInfo, - [(a,VirtualHpOffset)]) - -layOutDynConstr = layOutConstr False -layOutStaticConstr = layOutConstr True - -layOutConstr :: Bool -> DynFlags -> DataCon -> [(CgRep, a)] - -> (ClosureInfo, [(a, VirtualHpOffset)]) -layOutConstr is_static dflags data_con args - = (mkConInfo dflags is_static data_con tot_wds ptr_wds, - things_w_offsets) - where - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets dflags False{-not a thunk-} args -\end{code} - -@mkVirtHeapOffsets@ always returns boxed things with smaller offsets -than the unboxed things, and furthermore, the offsets in the result -list - -\begin{code} -mkVirtHeapOffsets - :: DynFlags - -> Bool -- True <=> is a thunk - -> [(CgRep,a)] -- Things to make offsets for - -> (WordOff, -- _Total_ number of words allocated - WordOff, -- Number of words allocated for *pointers* - [(a, VirtualHpOffset)]) - -- Things with their offsets from start of - -- object in order of increasing offset - --- First in list gets lowest offset, which is initial offset + 1. - -mkVirtHeapOffsets dflags is_thunk things - = let non_void_things = filterOut (isVoidArg . fst) things - (ptrs, non_ptrs) = separateByPtrFollowness non_void_things - (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs - (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs - in - (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) - where - hdr_size | is_thunk = thunkHdrSize dflags - | otherwise = fixedHdrSize dflags - - computeOffset wds_so_far (rep, thing) - = (wds_so_far + cgRepSizeW dflags rep, (thing, hdr_size + wds_so_far)) -\end{code} - - -%************************************************************************ -%* * - Lay out a static closure -%* * -%************************************************************************ - -Make a static closure, adding on any extra padding needed for CAFs, -and adding a static link field if necessary. - -\begin{code} -mkStaticClosureFields - :: DynFlags - -> ClosureInfo - -> CostCentreStack - -> Bool -- Has CAF refs - -> [CmmLit] -- Payload - -> [CmmLit] -- The full closure -mkStaticClosureFields dflags cl_info ccs caf_refs payload - = mkStaticClosure dflags info_lbl ccs payload padding_wds - static_link_field saved_info_field - where - info_lbl = infoTableLabelFromCI cl_info - - -- CAFs must have consistent layout, regardless of whether they - -- are actually updatable or not. The layout of a CAF is: - -- - -- 3 saved_info - -- 2 static_link - -- 1 indirectee - -- 0 info ptr - -- - -- the static_link and saved_info fields must always be in the same - -- place. So we use closureNeedsUpdSpace rather than - -- closureUpdReqd here: - - is_caf = closureNeedsUpdSpace cl_info - - padding_wds - | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] - - static_link_field - | is_caf || staticClosureNeedsLink cl_info = [static_link_value] - | otherwise = [] - - saved_info_field - | is_caf = [mkIntCLit dflags 0] - | otherwise = [] - - -- for a static constructor which has NoCafRefs, we set the - -- static link field to a non-zero value so the garbage - -- collector will ignore it. - static_link_value - | caf_refs = mkIntCLit dflags 0 - | otherwise = mkIntCLit dflags 1 - -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] - -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field - = [CmmLabel info_lbl] - ++ variable_header_words - ++ concatMap (padLitToWord dflags) payload - ++ padding_wds - ++ static_link_field - ++ saved_info_field - where - variable_header_words - = staticGranHdr - ++ staticParHdr - ++ staticProfHdr dflags ccs - ++ staticTickyHdr - -padLitToWord :: DynFlags -> CmmLit -> [CmmLit] -padLitToWord dflags lit = lit : padding pad_length - where width = typeWidth (cmmLitType dflags lit) - pad_length = wORD_SIZE dflags - widthInBytes width :: Int - - padding n | n <= 0 = [] - | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) - | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) - | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) - | otherwise = CmmInt 0 W64 : padding (n-8) -\end{code} - -%************************************************************************ -%* * -\subsection[CgHeapery-heap-overflow]{Heap overflow checking} -%* * -%************************************************************************ - -The new code for heapChecks. For GrAnSim the code for doing a heap check -and doing a context switch has been separated. Especially, the HEAP_CHK -macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for -doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the -beginning of every slow entry code in order to simulate the fetching of -closures. If fetching is necessary (i.e. current closure is not local) then -an automatic context switch is done. - --------------------------------------------------------------- -A heap/stack check at a function or thunk entry point. - -\begin{code} -funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code -funEntryChecks cl_info reg_save_code live code - = hpStkCheck cl_info True reg_save_code live code - -thunkEntryChecks :: ClosureInfo -> Code -> Code -thunkEntryChecks cl_info code - = hpStkCheck cl_info False noStmts (Just [node]) code - -hpStkCheck :: ClosureInfo -- Function closure - -> Bool -- Is a function? (not a thunk) - -> CmmStmts -- Register saves - -> Maybe [GlobalReg] -- Live registers - -> Code - -> Code - -hpStkCheck cl_info is_fun reg_save_code live code - = getFinalStackHW $ \ spHw -> do - { sp <- getRealSp - ; let stk_words = spHw - sp - ; initHeapUsage $ \ hpHw -> do - { -- Emit heap checks, but be sure to do it lazily so - -- that the conditionals on hpHw don't cause a black hole - codeOnly $ do - - dflags <- getDynFlags - - let (node_asst, full_live) - | nodeMustPointToIt dflags (closureLFInfo cl_info) - = (noStmts, live) - | otherwise - = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) - ,Just $ node : fromMaybe [] live) - -- Strictly speaking, we should tag node here. But if - -- node doesn't point to the closure, the code for the closure - -- cannot depend on the value of R1 anyway, so we're safe. - - full_save_code = node_asst `plusStmts` reg_save_code - - do_checks stk_words hpHw full_save_code rts_label full_live - tickyAllocHeap hpHw - ; setRealHp hpHw - ; code } - } - where - closure_lbl = closureLabelFromCI cl_info - - - rts_label | is_fun = CmmReg (CmmGlobal GCFun) - -- Function entry point - | otherwise = CmmReg (CmmGlobal GCEnter1) - -- Thunk or case return - -- In the thunk/case-return case, R1 points to a closure - -- which should be (re)-entered after GC -\end{code} - -Heap checks in a case alternative are nice and easy, provided this is -a bog-standard algebraic case. We have in our hand: - - * one return address, on the stack, - * one return value, in Node. - -the canned code for this heap check failure just pushes Node on the -stack, saying 'EnterGHC' to return. The scheduler will return by -entering the top value on the stack, which in turn will return through -the return address, getting us back to where we were. This is -therefore only valid if the return value is *lifted* (just being -boxed isn't good enough). - -For primitive returns, we have an unlifted value in some register -(either R1 or FloatReg1 or DblReg1). This means using specialised -heap-check code for these cases. - -\begin{code} -altHeapCheck - :: AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt - -- (Unboxed tuples are dealt with by ubxTupleHeapCheck) - -> Code -- Continuation - -> Code -altHeapCheck alt_type code - = initHeapUsage $ \ hpHw -> do - { codeOnly $ do - { do_checks 0 {- no stack chk -} hpHw - noStmts {- nothign to save -} - rts_label live - ; tickyAllocHeap hpHw } - ; setRealHp hpHw - ; code } - where - (rts_label, live) = gc_info alt_type - - mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l) - - gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node]) - - -- Do *not* enter R1 after a heap check in - -- a polymorphic case. It might be a function - -- and the entry code for a function (currently) - -- applies it - -- - -- However R1 is guaranteed to be a pointer - - gc_info (AlgAlt _) = (stg_gc_enter1, Just [node]) - -- Enter R1 after the heap check; it's a pointer - - gc_info (PrimAlt tc) - = case primRepToCgRep (tyConPrimRep tc) of - VoidArg -> (mkL "stg_gc_noregs", Just []) - FloatArg -> (mkL "stg_gc_f1", Just [FloatReg 1]) - DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1]) - LongArg -> (mkL "stg_gc_l1", Just [LongReg 1]) - -- R1 is boxed but unlifted: - PtrArg -> (mkL "stg_gc_unpt_r1", Just [node]) - -- R1 is unboxed: - NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node]) - - gc_info (UbxTupAlt _) = panic "altHeapCheck" -\end{code} - - -Unboxed tuple alternatives and let-no-escapes (the two most annoying -constructs to generate code for!) For unboxed tuple returns, there -are an arbitrary number of possibly unboxed return values, some of -which will be in registers, and the others will be on the stack. We -always organise the stack-resident fields into pointers & -non-pointers, and pass the number of each to the heap check code. - -\begin{code} -unbxTupleHeapCheck - :: [(Id, GlobalReg)] -- Live registers - -> WordOff -- no. of stack slots containing ptrs - -> WordOff -- no. of stack slots containing nonptrs - -> CmmStmts -- code to insert in the failure path - -> Code - -> Code - -unbxTupleHeapCheck regs ptrs nptrs fail_code code - -- We can't manage more than 255 pointers/non-pointers - -- in a generic heap check. - | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" - | otherwise - = initHeapUsage $ \ hpHw -> do - { dflags <- getDynFlags - ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! - (CmmLit (mkStgWordCLit dflags liveness)) - liveness = mkRegLiveness dflags regs ptrs nptrs - live = Just $ map snd regs - rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) - ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw - full_fail_code rts_label live - ; tickyAllocHeap hpHw } - ; setRealHp hpHw - ; code } - -\end{code} - - -%************************************************************************ -%* * - Heap/Stack Checks. -%* * -%************************************************************************ - -When failing a check, we save a return address on the stack and -jump to a pre-compiled code fragment that saves the live registers -and returns to the scheduler. - -The return address in most cases will be the beginning of the basic -block in which the check resides, since we need to perform the check -again on re-entry because someone else might have stolen the resource -in the meantime. - -\begin{code} -do_checks :: WordOff -- Stack headroom - -> WordOff -- Heap headroom - -> CmmStmts -- Assignments to perform on failure - -> CmmExpr -- Rts address to jump to on failure - -> Maybe [GlobalReg] -- Live registers - -> Code -do_checks 0 0 _ _ _ = nopC - -do_checks stk hp reg_save_code rts_lbl live - = do dflags <- getDynFlags - if hp > bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags - then sorry (unlines [ - "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE dflags) ++ " bytes.", - "", - "See: http://hackage.haskell.org/trac/ghc/ticket/4505", - "Suggestion: read data from a file instead of having large static data", - "structures in the code."]) - else do_checks' (mkIntExpr dflags (stk * wORD_SIZE dflags)) - (mkIntExpr dflags (hp * wORD_SIZE dflags)) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl live - --- The offsets are now in *bytes* -do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr - -> Maybe [GlobalReg] -> Code -do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live - = do { dflags <- getDynFlags - - -- Stk overflow if (Sp - stk_bytes < SpLim) - ; let stk_oflo = CmmMachOp (mo_wordULt dflags) - [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr], - CmmReg (CmmGlobal SpLim)] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt dflags) - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - ; doGranAllocate hp_expr - - -- The failure block: this saves the registers and jumps to - -- the appropriate RTS stub. - ; exit_blk_id <- forkLabelledCode $ do { - ; emitStmts reg_save_code - ; stmtC (CmmJump rts_lbl live) } - - -- In the case of a heap-check failure, we must also set - -- HpAlloc. NB. HpAlloc is *only* set if Hp has been - -- incremented by the heap check, it must not be set in the - -- event that a stack check failed, because the RTS stub will - -- retreat Hp by HpAlloc. - ; hp_blk_id <- if hp_nonzero - then forkLabelledCode $ do - stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr) - stmtC (CmmBranch exit_blk_id) - else return exit_blk_id - - -- Check for stack overflow *FIRST*; otherwise - -- we might bumping Hp and then failing stack oflo - ; whenC stk_nonzero - (stmtC (CmmCondBranch stk_oflo exit_blk_id)) - - ; whenC hp_nonzero - (stmtsC [CmmAssign hpReg - (cmmOffsetExprB dflags (CmmReg hpReg) hp_expr), - CmmCondBranch hp_oflo hp_blk_id]) - -- Bump heap pointer, and test for heap exhaustion - -- Note that we don't move the heap pointer unless the - -- stack check succeeds. Otherwise we might end up - -- with slop at the end of the current block, which can - -- confuse the LDV profiler. - } -\end{code} - -%************************************************************************ -%* * - Generic Heap/Stack Checks - used in the RTS -%* * -%************************************************************************ - -\begin{code} -hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code -hpChkGen bytes liveness reentry - = do dflags <- getDynFlags - let platform = targetPlatform dflags - assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, - mk_vanilla_assignment dflags 10 reentry ] - do_checks' (zeroExpr dflags) bytes False True assigns - stg_gc_gen (Just (activeStgRegs platform)) - --- a heap check where R1 points to the closure to enter on return, and --- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). -hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code -hpChkNodePointsAssignSp0 bytes sp0 - = do dflags <- getDynFlags - do_checks' (zeroExpr dflags) bytes False True assign - stg_gc_enter1 (Just [node]) - where assign = oneStmt (CmmStore (CmmReg spReg) sp0) - -stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code -stkChkGen bytes liveness reentry - = do dflags <- getDynFlags - let platform = targetPlatform dflags - assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, - mk_vanilla_assignment dflags 10 reentry ] - do_checks' bytes (zeroExpr dflags) True False assigns - stg_gc_gen (Just (activeStgRegs platform)) - -mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt -mk_vanilla_assignment dflags n e - = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType dflags e)))) e - -stkChkNodePoints :: CmmExpr -> Code -stkChkNodePoints bytes - = do dflags <- getDynFlags - do_checks' bytes (zeroExpr dflags) True False noStmts - stg_gc_enter1 (Just [node]) - -stg_gc_gen :: CmmExpr -stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) -stg_gc_enter1 :: CmmExpr -stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) -\end{code} - -%************************************************************************ -%* * -\subsection[initClosure]{Initialise a dynamic closure} -%* * -%************************************************************************ - -@allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp -to account for this. - -\begin{code} -allocDynClosure - :: ClosureInfo - -> CmmExpr -- Cost Centre to stick in the object - -> CmmExpr -- Cost Centre to blame for this alloc - -- (usually the same; sometimes "OVERHEAD") - - -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object - -- ie Info ptr has offset zero. - -> FCode VirtualHpOffset -- Returns virt offset of object - -allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets - = do { virt_hp <- getVirtHp - - -- FIND THE OFFSET OF THE INFO-PTR WORD - ; dflags <- getDynFlags - ; let info_offset = virt_hp + 1 - -- info_offset is the VirtualHpOffset of the first - -- word of the new object - -- Remember, virtHp points to last allocated word, - -- ie 1 *before* the info-ptr word of new object. - - info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) - hdr_w_offsets = initDynHdr dflags info_ptr use_cc `zip` [0..] - - -- SAY WHAT WE ARE ABOUT TO DO - ; profDynAlloc cl_info use_cc - ; tickyDynAlloc cl_info - - -- ALLOCATE THE OBJECT - ; base <- getHpRelOffset info_offset - ; hpStore base (hdr_w_offsets ++ amodes_with_offsets) - - -- BUMP THE VIRTUAL HEAP POINTER - ; setVirtHp (virt_hp + closureSize dflags cl_info) - - -- RETURN PTR TO START OF OBJECT - ; returnFC info_offset } - - -initDynHdr :: DynFlags - -> CmmExpr - -> CmmExpr -- Cost centre to put in object - -> [CmmExpr] -initDynHdr dflags info_ptr cc - = [info_ptr] - -- ToDo: Gransim stuff - -- ToDo: Parallel stuff - ++ dynProfHdr dflags cc - -- No ticky header - -hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code --- Store the item (expr,off) in base[off] -hpStore base es - = do dflags <- getDynFlags - stmtsC [ CmmStore (cmmOffsetW dflags base off) val - | (val, off) <- es ] - -emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code -emitSetDynHdr base info_ptr ccs - = do dflags <- getDynFlags - hpStore base (zip (initDynHdr dflags info_ptr ccs) [0..]) -\end{code} diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs deleted file mode 100644 index 407de7b647..0000000000 --- a/compiler/codeGen/CgHpc.hs +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for coverage --- --- (c) Galois Connections, Inc. 2006 --- ------------------------------------------------------------------------------ - -module CgHpc (cgTickBox, hpcTable) where - -import OldCmm -import CLabel -import Module -import OldCmmUtils -import CgUtils -import CgMonad -import HscTypes - -cgTickBox :: Module -> Int -> Code -cgTickBox mod n = do - dflags <- getDynFlags - let tick_box = (cmmIndex dflags W64 - (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) - n - ) - stmtsC [ CmmStore tick_box - (CmmMachOp (MO_Add W64) - [ CmmLoad tick_box b64 - , CmmLit (CmmInt 1 W64) - ]) - ] - -hpcTable :: Module -> HpcInfo -> Code -hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitDataLits (mkHpcTicksLabel this_mod) $ - [ CmmInt 0 W64 - | _ <- take hpc_tickCount [0::Int ..] - ] - -hpcTable _ (NoHpcInfo {}) = error "TODO: impossible" diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs deleted file mode 100644 index be16bf6adf..0000000000 --- a/compiler/codeGen/CgInfoTbls.hs +++ /dev/null @@ -1,374 +0,0 @@ ------------------------------------------------------------------------------ --- --- Building info tables. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgInfoTbls ( - emitClosureCodeAndInfoTable, - emitInfoTableAndCode, - emitReturnTarget, emitAlgReturnTarget, - emitReturnInstr, - stdInfoTableSizeB, - entryCode, closureInfoPtr, - getConstrTag, - cmmGetClosureType, - infoTable, infoTableClosureType, - infoTablePtrs, infoTableNonPtrs, - funInfoTable - ) where - - -#include "HsVersions.h" - -import ClosureInfo -import SMRep -import CgBindery -import CgCallConv -import CgUtils -import CgMonad -import CmmUtils - -import OldCmm -import CLabel -import Name -import Unique - -import DynFlags -import Util -import Outputable - -------------------------------------------------------------------------- --- --- Generating the info table and code for a closure --- -------------------------------------------------------------------------- - --- Here we make an info table of type 'CmmInfo'. The concrete --- representation as a list of 'CmmAddr' is handled later --- in the pipeline by 'cmmToRawCmm'. - -emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code -emitClosureCodeAndInfoTable cl_info args body - = do { dflags <- getDynFlags - ; blks <- cgStmtsToBlocks body - ; info <- mkCmmInfo cl_info - ; emitInfoTableAndCode (entryLabelFromCI dflags cl_info) info args blks } - --- Convert from 'ClosureInfo' to 'CmmInfo'. --- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) -mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable -mkCmmInfo cl_info - = do dflags <- getDynFlags - return (CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, - cit_rep = closureSMRep cl_info, - cit_prof = prof dflags, - cit_srt = closureSRT cl_info }) - where - prof dflags | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 - ty_descr_w8 = stringToWord8s (closureTypeDescr cl_info) - val_descr_w8 = stringToWord8s (closureValDescr cl_info) - -------------------------------------------------------------------------- --- --- Generating the info table and code for a return point --- -------------------------------------------------------------------------- - --- The concrete representation as a list of 'CmmAddr' is handled later --- in the pipeline by 'cmmToRawCmm'. - -emitReturnTarget - :: Name - -> CgStmts -- The direct-return code (if any) - -> FCode CLabel -emitReturnTarget name stmts - = do dflags <- getDynFlags - srt_info <- getSRTInfo - blks <- cgStmtsToBlocks stmts - frame <- mkStackLayout - let smrep = mkStackRep (mkLiveness dflags frame) - info = CmmInfoTable { cit_lbl = info_lbl - , cit_prof = NoProfilingInfo - , cit_rep = smrep - , cit_srt = srt_info } - emitInfoTableAndCode entry_lbl info args blks - return info_lbl - where - args = {- trace "emitReturnTarget: missing args" -} [] - uniq = getUnique name - info_lbl = mkReturnInfoLabel uniq - entry_lbl = mkReturnPtLabel uniq - --- Build stack layout information from the state of the 'FCode' monad. --- Should go away once 'codeGen' starts using the CPS conversion --- pass to handle the stack. Until then, this is really just --- here to convert from the 'codeGen' representation of the stack --- to the 'CmmInfo' representation of the stack. --- --- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap. - -{- -This seems to be a very error prone part of the code. -It is surprisingly prone to off-by-one errors, because -it converts between offset form (codeGen) and list form (CmmInfo). -Thus a bit of explanation is in order. -Fortunately, this code should go away once the code generator -starts using the CPS conversion pass to handle the stack. - -The stack looks like this: - - | | - |-------------| -frame_sp --> | return addr | - |-------------| - | dead slot | - |-------------| - | live ptr b | - |-------------| - | live ptr a | - |-------------| -real_sp --> | return addr | - +-------------+ - -Both 'frame_sp' and 'real_sp' are measured downwards -(i.e. larger frame_sp means smaller memory address). - -For that frame we want a result like: [Just a, Just b, Nothing] -Note that the 'head' of the list is the top -of the stack, and that the return address -is not present in the list (it is always assumed). --} -mkStackLayout :: FCode [Maybe LocalReg] -mkStackLayout = do - dflags <- getDynFlags - StackUsage { realSp = real_sp, - frameSp = frame_sp } <- getStkUsage - binds <- getLiveStackBindings - let frame_size = real_sp - frame_sp - retAddrSizeW - rel_binds = reverse $ sortWith fst - [(offset - frame_sp - retAddrSizeW, b) - | (offset, b) <- binds] - - WARN( not (all (\bind -> fst bind >= 0) rel_binds), - ppr binds $$ ppr rel_binds $$ - ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) - return $ stack_layout dflags rel_binds frame_size - -stack_layout :: DynFlags - -> [(VirtualSpOffset, CgIdInfo)] - -> WordOff - -> [Maybe LocalReg] -stack_layout _ [] sizeW = replicate sizeW Nothing -stack_layout dflags ((off, bind):binds) sizeW | off == sizeW - 1 = - (Just stack_bind) : (stack_layout dflags binds (sizeW - rep_size)) - where - rep_size = cgRepSizeW dflags (cgIdInfoArgRep bind) - stack_bind = LocalReg unique machRep - unique = getUnique (cgIdInfoId bind) - machRep = argMachRep dflags (cgIdInfoArgRep bind) -stack_layout dflags binds@(_:_) sizeW | otherwise = - Nothing : (stack_layout dflags binds (sizeW - 1)) - -{- Another way to write the function that might be less error prone (untested) -stack_layout offsets sizeW = result - where - y = map (flip lookup offsets) [0..] - -- offsets -> nothing and just (each slot is one word) - x = take sizeW y -- set the frame size - z = clip x -- account for multi-word slots - result = map mk_reg z - - clip [] = [] - clip list@(x : _) = x : clip (drop count list) - ASSERT(all isNothing (tail (take count list))) - - count Nothing = 1 - count (Just x) = cgRepSizeW (cgIdInfoArgRep x) - - mk_reg Nothing = Nothing - mk_reg (Just x) = LocalReg unique machRep kind - where - unique = getUnique (cgIdInfoId x) - machRep = argMachrep (cgIdInfoArgRep bind) - kind = if isFollowableArg (cgIdInfoArgRep bind) - then GCKindPtr - else GCKindNonPtr --} - -emitAlgReturnTarget - :: Name -- Just for its unique - -> [(ConTagZ, CgStmts)] -- Tagged branches - -> Maybe CgStmts -- Default branch (if any) - -> Int -- family size - -> FCode (CLabel, SemiTaggingStuff) - -emitAlgReturnTarget name branches mb_deflt fam_sz - = do { blks <- getCgStmts $ do - -- is the constructor tag in the node reg? - dflags <- getDynFlags - if isSmallFamily dflags fam_sz - then do -- yes, node has constr. tag - let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg) - branches' = [(tag+1,branch)|(tag,branch)<-branches] - emitSwitch tag_expr branches' mb_deflt 1 fam_sz - else do -- no, get tag from info table - let -- Note that ptr _always_ has tag 1 - -- when the family size is big enough - untagged_ptr = cmmRegOffB nodeReg (-1) - tag_expr = getConstrTag dflags untagged_ptr - emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) - ; lbl <- emitReturnTarget name blks - ; return (lbl, Nothing) } - -- Nothing: the internal branches in the switch don't have - -- global labels, so we can't use them at the 'call site' - --------------------------------- -emitReturnInstr :: Maybe [GlobalReg] -> Code -emitReturnInstr live - = do { dflags <- getDynFlags - ; info_amode <- getSequelAmode - ; stmtC (CmmJump (entryCode dflags info_amode) live) } - ------------------------------------------------------------------------------ --- --- Info table offsets --- ------------------------------------------------------------------------------ - -stdInfoTableSizeW :: DynFlags -> WordOff --- The size of a standard info table varies with profiling/ticky etc, --- so we can't get it from Constants --- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW dflags - = size_fixed + size_prof - where - size_fixed = 2 -- layout, type - size_prof | gopt Opt_SccProfilingOn dflags = 2 - | otherwise = 0 - -stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags - -stdSrtBitmapOffset :: DynFlags -> ByteOff --- Byte offset of the SRT bitmap half-word which is --- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags - -stdClosureTypeOffset :: DynFlags -> ByteOff --- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags - -stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags - -------------------------------------------------------------------------- --- --- Accessing fields of an info table --- -------------------------------------------------------------------------- - -closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer and returns the info table pointer -closureInfoPtr dflags e = CmmLoad e (bWord dflags) - -entryCode :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns its entry code -entryCode dflags e - | tablesNextToCode dflags = e - | otherwise = CmmLoad e (bWord dflags) - -getConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the *zero-indexed* --- constructor tag obtained from the info table --- This lives in the SRT field of the info table --- (constructors don't need SRTs). -getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes a closure pointer, and return the closure type --- obtained from the info table -cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] - where - info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) - -infoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info pointer (the first word of a closure) --- and returns a pointer to the first word of the standard-form --- info table, excluding the entry-code word (if present) -infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer - -infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the constr tag --- field of the info table (same as the srt_bitmap field) -infoTableConstrTag = infoTableSrtBitmap - -infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the srt_bitmap --- field of the info table -infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) - -infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr --- Takes an info table pointer (from infoTable) and returns the closure type --- field of the info table. -infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) - -infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) - -infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr -infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) - -funInfoTable :: DynFlags -> CmmExpr -> CmmExpr --- Takes the info pointer of a function, --- and returns a pointer to the first word of the StgFunInfoExtra struct --- in the info table. -funInfoTable dflags info_ptr - | tablesNextToCode dflags - = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) - | otherwise - = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) - -- Past the entry code pointer - -------------------------------------------------------------------------- --- --- Emit the code for a closure (or return address) --- and its associated info table --- -------------------------------------------------------------------------- - --- The complication here concerns whether or not we can --- put the info table next to the code - -emitInfoTableAndCode - :: CLabel -- Label of entry or ret - -> CmmInfoTable -- ...the info table - -> [CmmFormal] -- ...args - -> [CmmBasicBlock] -- ...and body - -> Code - -emitInfoTableAndCode entry_ret_lbl info args blocks - = emitProc (Just info) entry_ret_lbl args blocks - diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs deleted file mode 100644 index 610869ad89..0000000000 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ /dev/null @@ -1,215 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -%******************************************************** -%* * -\section[CgLetNoEscape]{Handling ``let-no-escapes''} -%* * -%******************************************************** - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgLetNoEscape ( cgLetNoEscapeClosure ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} CgExpr ( cgExpr ) - -import StgSyn -import CgMonad - -import CgBindery -import CgCase -import CgCon -import CgHeapery -import CgInfoTbls -import CgStackery -import OldCmm -import OldCmmUtils -import CLabel -import ClosureInfo -import CostCentre -import Id -import BasicTypes -\end{code} - -%************************************************************************ -%* * -\subsection[what-is-non-escaping]{What {\em is} a ``non-escaping let''?} -%* * -%************************************************************************ - -[The {\em code} that detects these things is elsewhere.] - -Consider: -\begin{verbatim} - let x = fvs \ args -> e - in - if ... then x else - if ... then x else ... -\end{verbatim} -@x@ is used twice (so we probably can't unfold it), but when it is -entered, the stack is deeper than it was when the definition of @x@ -happened. Specifically, if instead of allocating a closure for @x@, -we saved all @x@'s fvs on the stack, and remembered the stack depth at -that moment, then whenever we enter @x@ we can simply set the stack -pointer(s) to these remembered (compile-time-fixed) values, and jump -to the code for @x@. - -All of this is provided x is: -\begin{enumerate} -\item -non-updatable; -\item -guaranteed to be entered before the stack retreats -- ie x is not -buried in a heap-allocated closure, or passed as an argument to something; -\item -all the enters have exactly the right number of arguments, -no more no less; -\item -all the enters are tail calls; that is, they return to the -caller enclosing the definition of @x@. -\end{enumerate} - -Under these circumstances we say that @x@ is {\em non-escaping}. - -An example of when (4) does {\em not} hold: -\begin{verbatim} - let x = ... - in case x of ...alts... -\end{verbatim} - -Here, @x@ is certainly entered only when the stack is deeper than when -@x@ is defined, but here it must return to \tr{...alts...} So we can't -just adjust the stack down to @x@'s recalled points, because that -would lost @alts@' context. - -Things can get a little more complicated. Consider: -\begin{verbatim} - let y = ... - in let x = fvs \ args -> ...y... - in ...x... -\end{verbatim} - -Now, if @x@ is used in a non-escaping way in \tr{...x...}, {\em and} -@y@ is used in a non-escaping way in \tr{...y...}, {\em then} @y@ is -non-escaping. - -@x@ can even be recursive! Eg: -\begin{verbatim} - letrec x = [y] \ [v] -> if v then x True else ... - in - ...(x b)... -\end{verbatim} - - -%************************************************************************ -%* * -\subsection[codeGen-for-non-escaping]{Generating code for a ``non-escaping let''} -%* * -%************************************************************************ - - -Generating code for this is fun. It is all very very similar to what -we do for a case expression. The duality is between -\begin{verbatim} - let-no-escape x = b - in e -\end{verbatim} -and -\begin{verbatim} - case e of ... -> b -\end{verbatim} - -That is, the RHS of @x@ (ie @b@) will execute {\em later}, just like -the alternative of the case; it needs to be compiled in an environment -in which all volatile bindings are forgotten, and the free vars are -bound only to stable things like stack locations.. The @e@ part will -execute {\em next}, just like the scrutinee of a case. - -First, we need to save all @x@'s free vars -on the stack, if they aren't there already. - -\begin{code} -cgLetNoEscapeClosure - :: Id -- binder - -> CostCentreStack -- NB: *** NOT USED *** ToDo (WDP 94/06) - -> StgBinderInfo -- NB: ditto - -> StgLiveVars -- variables live in RHS, including the binders - -- themselves in the case of a recursive group - -> EndOfBlockInfo -- where are we going to? - -> Maybe VirtualSpOffset -- Slot for current cost centre - -> RecFlag -- is the binding recursive? - -> [Id] -- args (as in \ args -> body) - -> StgExpr -- body (as in above) - -> FCode (Id, CgIdInfo) - --- ToDo: deal with the cost-centre issues - -cgLetNoEscapeClosure - bndr cc _ full_live_in_rhss - rhs_eob_info cc_slot _ args body - = let - arity = length args - lf_info = mkLFLetNoEscape arity - in - -- saveVolatileVarsAndRegs done earlier in cgExpr. - - do { dflags <- getDynFlags - ; (vSp, _) <- forkEvalHelp rhs_eob_info - - (do { allocStackTop retAddrSizeW - ; nukeDeadBindings full_live_in_rhss }) - - (do { deAllocStackTop retAddrSizeW - ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc - cc_slot args body - - -- Ignore the label that comes back from - -- mkRetDirectTarget. It must be conjured up elswhere - ; _ <- emitReturnTarget (idName bndr) abs_c - ; return () }) - - ; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) } -\end{code} - -\begin{code} -cgLetNoEscapeBody :: Id -- Name of the joint point - -> CostCentreStack - -> Maybe VirtualSpOffset - -> [Id] -- Args - -> StgExpr -- Body - -> Code - -cgLetNoEscapeBody bndr _ cc_slot all_args body = do - { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args - - -- restore the saved cost centre. BUT: we must not free the stack slot - -- containing the cost centre, because it might be needed for a - -- recursive call to this let-no-escape. - ; restoreCurrentCostCentre cc_slot False{-don't free-} - - -- Enter the closures cc, if required - ; -- enterCostCentreCode closure_info cc IsFunction - - -- The "return address" slot doesn't have a return address in it; - -- but the heap-check needs it filled in if the heap-check fails. - -- So we pass code to fill it in to the heap-check macro - ; sp_rel <- getSpRelOffset ret_slot - - ; let lbl = mkReturnInfoLabel (idUnique bndr) - frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl)) - - -- Do heap check [ToDo: omit for non-recursive case by recording in - -- in envt and absorbing at call site] - ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst - (cgExpr body) - } -\end{code} diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs deleted file mode 100644 index f776af3b3b..0000000000 --- a/compiler/codeGen/CgMonad.lhs +++ /dev/null @@ -1,849 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgMonad]{The code generation monad} - -See the beginning of the top-level @CodeGen@ module, to see how this monadic -stuff fits into the Big Picture. - -\begin{code} - -{-# LANGUAGE BangPatterns #-} -module CgMonad ( - Code, FCode, - - initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, - returnFC, fixC, fixC_, checkedAbsC, - stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC, - newUnique, newUniqSupply, - - CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks, - getCgStmts', getCgStmts, - noCgStmts, oneCgStmt, consCgStmt, - - getCmm, - emitDecl, emitProc, emitSimpleProc, - - forkLabelledCode, - forkClosureBody, forkStatics, forkAlts, forkEval, - forkEvalHelp, forkProc, codeOnly, - SemiTaggingStuff, ConTagZ, - - EndOfBlockInfo(..), - setEndOfBlockInfo, getEndOfBlockInfo, - - setSRT, getSRT, - setSRTLabel, getSRTLabel, - setTickyCtrLabel, getTickyCtrLabel, - - StackUsage(..), HeapUsage(..), - VirtualSpOffset, VirtualHpOffset, - initStkUsage, initHpUsage, - getHpUsage, setHpUsage, - heapHWM, - - getModuleName, - - Sequel(..), - - -- ideally we wouldn't export these, but some other modules access - -- internal state - getState, setState, getInfoDown, getDynFlags, getThisPackage, - - -- more localised access to monad state - getStkUsage, setStkUsage, - getBinds, setBinds, getStaticBinds, - - -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..) - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) - -import DynFlags -import BlockId -import OldCmm -import OldCmmUtils -import CLabel -import StgSyn (SRT) -import ClosureInfo( ConTagZ ) -import SMRep -import Module -import Id -import VarEnv -import OrdList -import Unique -import UniqSupply -import Util -import Outputable - -import Control.Monad -import Data.List - -infixr 9 `thenC` -infixr 9 `thenFC` -\end{code} - -%************************************************************************ -%* * -\subsection[CgMonad-environment]{Stuff for manipulating environments} -%* * -%************************************************************************ - -This monadery has some information that it only passes {\em downwards}, as well -as some ``state'' which is modified as we go along. - -\begin{code} - --- | State only passed *downwards* by the monad -data CgInfoDownwards - = MkCgInfoDown { - cgd_dflags :: DynFlags, -- current flag settings - cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- label of the current SRT - cgd_srt :: SRT, -- the current SRT - cgd_ticky :: CLabel, -- current destination for ticky counts - cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: - } - --- | Setup initial @CgInfoDownwards@ for the code gen -initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards -initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_srt = error "initC: srt", - cgd_ticky = mkTopTickyCtrLabel, - cgd_eob = initEobInfo - } - --- | State passed around and modified during code generation -data CgState - = MkCgState { - cgs_stmts :: OrdList CgStmt, - -- Current proc - cgs_tops :: OrdList CmmDecl, - -- Other procedures and data blocks in this compilation unit - -- Both the latter two are ordered only so that we can - -- reduce forward references, when it's easy to do so - - cgs_binds :: CgBindings, - -- [Id -> info] : *local* bindings environment Bindings for - -- top-level things are given in the info-down part - - cgs_stk_usg :: StackUsage, - cgs_hp_usg :: HeapUsage, - cgs_uniqs :: UniqSupply - } - --- | Setup initial @CgState@ for the code gen -initCgState :: UniqSupply -> CgState -initCgState uniqs - = MkCgState { cgs_stmts = nilOL, - cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_stk_usg = initStkUsage, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs - } - --- | @EndOfBlockInfo@ tells what to do at the end of this block of code or, if --- the expression is a @case@, what to do at the end of each alternative. -data EndOfBlockInfo - = EndOfBlockInfo - VirtualSpOffset -- Args Sp: trim the stack to this point at a - -- return; push arguments starting just - -- above this point on a tail call. - -- - -- This is therefore the stk ptr as seen - -- by a case alternative. - Sequel - --- | Standard @EndOfBlockInfo@ where the continuation is on the stack -initEobInfo :: EndOfBlockInfo -initEobInfo = EndOfBlockInfo 0 OnStack - --- | @Sequel@ is a representation of the next continuation to jump to --- after the current function. --- --- Any addressing modes inside @Sequel@ must be ``robust,'' in the sense --- that it must survive stack pointer adjustments at the end of the block. -data Sequel - = OnStack -- Continuation is on the stack - - | CaseAlts - CLabel -- Jump to this; if the continuation is for a vectored - -- case this might be the label of a return vector - SemiTaggingStuff - Id -- The case binder, only used to see if it's dead - -type SemiTaggingStuff - = Maybe -- Maybe we don't have any semi-tagging stuff... - ([(ConTagZ, CmmLit)], -- Alternatives - CmmLit) -- Default (will be a can't happen RTS label if can't happen) - --- The case branch is executed only from a successful semitagging --- venture, when a case has looked at a variable, found that it's --- evaluated, and wants to load up the contents and go to the join --- point. -\end{code} - -%************************************************************************ -%* * - CgStmt type -%* * -%************************************************************************ - -The CgStmts type is what the code generator outputs: it is a tree of -statements, including in-line labels. The job of flattenCgStmts is to turn -this into a list of basic blocks, each of which ends in a jump statement -(either a local branch or a non-local jump). - -\begin{code} -type CgStmts = OrdList CgStmt - -data CgStmt - = CgStmt CmmStmt - | CgLabel BlockId - | CgFork BlockId CgStmts - -flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock] -flattenCgStmts id stmts = - case flatten (fromOL stmts) of - ([],blocks) -> blocks - (block,blocks) -> BasicBlock id block : blocks - where - flatten [] = ([],[]) - - -- A label at the end of a function or fork: this label must not be reachable, - -- but it might be referred to from another BB that also isn't reachable. - -- Eliminating these has to be done with a dead-code analysis. For now, - -- we just make it into a well-formed block by adding a recursive jump. - flatten [CgLabel id] - = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] ) - - -- A jump/branch: throw away all the code up to the next label, because - -- it is unreachable. Be careful to keep forks that we find on the way. - flatten (CgStmt stmt : stmts) - | isJump stmt - = case dropWhile isOrdinaryStmt stmts of - [] -> ( [stmt], [] ) - [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]]) - (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks ) - where (block,blocks) = flatten stmts - (CgFork fork_id stmts : ss) -> - flatten (CgFork fork_id stmts : CgStmt stmt : ss) - (CgStmt {} : _) -> panic "CgStmt not seen as ordinary" - - flatten (s:ss) = - case s of - CgStmt stmt -> (stmt:block,blocks) - CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks) - CgFork fork_id stmts -> - (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks) - where (fork_block, fork_blocks) = flatten (fromOL stmts) - where (block,blocks) = flatten ss - -isJump :: CmmStmt -> Bool -isJump (CmmJump _ _) = True -isJump (CmmBranch _ ) = True -isJump (CmmSwitch _ _) = True -isJump (CmmReturn ) = True -isJump _ = False - -isOrdinaryStmt :: CgStmt -> Bool -isOrdinaryStmt (CgStmt _) = True -isOrdinaryStmt _ = False -\end{code} - -%************************************************************************ -%* * - Stack and heap models -%* * -%************************************************************************ - -\begin{code} -type VirtualHpOffset = WordOff -- Both are in -type VirtualSpOffset = WordOff -- units of words - --- | Stack usage information during code generation. --- --- INVARIANT: The environment contains no Stable references to --- stack slots below (lower offset) frameSp --- It can contain volatile references to this area though. -data StackUsage - = StackUsage { - virtSp :: VirtualSpOffset, - -- Virtual offset of topmost allocated slot - - frameSp :: VirtualSpOffset, - -- Virtual offset of the return address of the enclosing frame. - -- This RA describes the liveness/pointedness of - -- all the stack from frameSp downwards - -- INVARIANT: less than or equal to virtSp - - freeStk :: [VirtualSpOffset], - -- List of free slots, in *increasing* order - -- INVARIANT: all <= virtSp - -- All slots <= virtSp are taken except these ones - - realSp :: VirtualSpOffset, - -- Virtual offset of real stack pointer register - - hwSp :: VirtualSpOffset - } -- Highest value ever taken by virtSp - --- | Heap usage information during code generation. --- --- virtHp keeps track of the next location to allocate an object at. realHp --- keeps track of what the Hp STG register actually points to. The reason these --- aren't always the same is that we want to be able to move the realHp in one --- go when allocating numerous objects to save having to bump it each time. --- virtHp we do bump each time but it doesn't create corresponding inefficient --- machine code. -data HeapUsage - = HeapUsage { - virtHp :: VirtualHpOffset, -- Virtual offset of highest allocated word - realHp :: VirtualHpOffset -- Virtual offset of real heap ptr - } - --- | Return the heap usage high water mark -heapHWM :: HeapUsage -> VirtualHpOffset -heapHWM = virtHp - - --- | Initial stack usage -initStkUsage :: StackUsage -initStkUsage - = StackUsage { - virtSp = 0, - frameSp = 0, - freeStk = [], - realSp = 0, - hwSp = 0 - } - --- | Initial heap usage -initHpUsage :: HeapUsage -initHpUsage - = HeapUsage { - virtHp = 0, - realHp = 0 - } - --- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to --- be the max of the high water marks of $arg1$ and $arg2$. -stateIncUsage :: CgState -> CgState -> CgState -stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg }) - = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg, - cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg } - `addCodeBlocksFrom` s2 - --- | Similar to @stateIncUsafe@ but we don't max the heap high-watermark --- because @stateIncUsageEval@ is used only in forkEval, which in turn is only --- used for blocks of code which do their own heap-check. -stateIncUsageEval :: CgState -> CgState -> CgState -stateIncUsageEval s1 s2 - = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) } - `addCodeBlocksFrom` s2 - --- | Add code blocks from the latter to the former --- (The cgs_stmts will often be empty, but not always; see @codeOnly@) -addCodeBlocksFrom :: CgState -> CgState -> CgState -s1 `addCodeBlocksFrom` s2 - = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2, - cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } - --- | Set @HeapUsage@ virtHp to max of current or $arg2$. -maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage -hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } - --- | Set @StackUsage@ hwSp to max of current or $arg2$. -maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage -stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw } -\end{code} - -%************************************************************************ -%* * - The FCode monad -%* * -%************************************************************************ - -\begin{code} -newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState)) -type Code = FCode () - -instance Monad FCode where - (>>=) = thenFC - return = returnFC - -{-# INLINE thenC #-} -{-# INLINE thenFC #-} -{-# INLINE returnFC #-} - -initC :: IO CgState -initC = do { uniqs <- mkSplitUniqSupply 'c' - ; return (initCgState uniqs) } - -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) -runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st - -returnFC :: a -> FCode a -returnFC val = FCode $ \_ state -> (val, state) - -thenC :: Code -> FCode a -> FCode a -thenC (FCode m) (FCode k) = FCode $ \info_down state -> - let (_,new_state) = m info_down state - in k info_down new_state - -listCs :: [Code] -> Code -listCs [] = return () -listCs (fc:fcs) = fc >> listCs fcs - -mapCs :: (a -> Code) -> [a] -> Code -mapCs = mapM_ - -thenFC :: FCode a -> (a -> FCode c) -> FCode c -thenFC (FCode m) k = FCode $ \info_down state -> - let (m_result, new_state) = m info_down state - (FCode kcode) = k m_result - in kcode info_down new_state - -listFCs :: [FCode a] -> FCode [a] -listFCs = sequence - -mapFCs :: (a -> FCode b) -> [a] -> FCode [b] -mapFCs = mapM - --- | Knot-tying combinator for @FCode@ -fixC :: (a -> FCode a) -> FCode a -fixC fcode = FCode $ \info_down state -> - let FCode fc = fcode v - result@(v,_) = fc info_down state - in result - --- | Knot-tying combinator that throws result away -fixC_ :: (a -> FCode a) -> FCode () -fixC_ fcode = fixC fcode >> return () -\end{code} - -%************************************************************************ -%* * - Operators for getting and setting the state and "info_down". -%* * -%************************************************************************ - -\begin{code} -getState :: FCode CgState -getState = FCode $ \_ state -> (state, state) - -setState :: CgState -> FCode () -setState state = FCode $ \_ _ -> ((), state) - -getStkUsage :: FCode StackUsage -getStkUsage = do - state <- getState - return $ cgs_stk_usg state - -setStkUsage :: StackUsage -> Code -setStkUsage new_stk_usg = do - state <- getState - setState $ state {cgs_stk_usg = new_stk_usg} - -getHpUsage :: FCode HeapUsage -getHpUsage = do - state <- getState - return $ cgs_hp_usg state - -setHpUsage :: HeapUsage -> Code -setHpUsage new_hp_usg = do - state <- getState - setState $ state {cgs_hp_usg = new_hp_usg} - -getBinds :: FCode CgBindings -getBinds = do - state <- getState - return $ cgs_binds state - -setBinds :: CgBindings -> FCode () -setBinds new_binds = do - state <- getState - setState $ state {cgs_binds = new_binds} - -getStaticBinds :: FCode CgBindings -getStaticBinds = do - info <- getInfoDown - return (cgd_statics info) - -withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> - let (retval, state2) = fcode info_down newstate - in ((retval, state2), state) - -newUniqSupply :: FCode UniqSupply -newUniqSupply = do - state <- getState - let (us1, us2) = splitUniqSupply (cgs_uniqs state) - setState $ state { cgs_uniqs = us1 } - return us2 - -newUnique :: FCode Unique -newUnique = do - us <- newUniqSupply - return (uniqFromSupply us) - -getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (info_down, state) - -instance HasDynFlags FCode where - getDynFlags = liftM cgd_dflags getInfoDown - -getThisPackage :: FCode PackageId -getThisPackage = liftM thisPackage getDynFlags - -withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state - -doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) -doFCode (FCode fcode) info_down state = fcode info_down state -\end{code} - -%************************************************************************ -%* * - Forking -%* * -%************************************************************************ - -\begin{code} - --- | Takes code and compiles it in a completely fresh environment, except that --- compilation info and statics are passed in unchanged. The current --- environment is passed on completely unaltered, except that the Cmm code --- from the fork is incorporated. -forkClosureBody :: Code -> Code -forkClosureBody body_code = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - let body_info_down = info { cgd_eob = initEobInfo } - ((), fork_state) = doFCode body_code body_info_down (initCgState us) - - ASSERT( isNilOL (cgs_stmts fork_state) ) - setState $ state `addCodeBlocksFrom` fork_state - --- | @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come --- from the current bindings, but which is otherwise freshly initialised. --- The Cmm returned is attached to the current state, but the bindings and --- usage information is otherwise unchanged. -forkStatics :: FCode a -> FCode a -forkStatics body_code = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - let rhs_info_down = info { cgd_statics = cgs_binds state, - cgd_eob = initEobInfo } - (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) - - ASSERT( isNilOL (cgs_stmts fork_state_out) ) - setState (state `addCodeBlocksFrom` fork_state_out) - return result - --- | @forkProc@ takes a code and compiles it in the current environment, --- returning the basic blocks thus constructed. The current environment is --- passed on completely unchanged. It is pretty similar to @getBlocks@, except --- that the latter does affect the environment. -forkProc :: Code -> FCode CgStmts -forkProc body_code = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - let fork_state_in = (initCgState us) - { cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - (code_blks, fork_state_out) = doFCode (getCgStmts body_code) - info fork_state_in - setState $ state `stateIncUsageEval` fork_state_out - return code_blks - --- Emit any code from the inner thing into the outer thing --- Do not affect anything else in the outer state --- Used in almost-circular code to prevent false loop dependencies -codeOnly :: Code -> Code -codeOnly body_code = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - ((), fork_state_out) = doFCode body_code info fork_state_in - setState $ state `addCodeBlocksFrom` fork_state_out - --- | @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and an --- an fcode for the default case $d$, and compiles each in the current --- environment. The current environment is passed on unmodified, except that: --- * the worst stack high-water mark is incorporated --- * the virtual Hp is moved on to the worst virtual Hp for the branches -forkAlts :: [FCode a] -> FCode [a] -forkAlts branch_fcodes = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - let compile us branch = (us2, doFCode branch info branch_state) - where - (us1,us2) = splitUniqSupply us - branch_state = (initCgState us1) { - cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - (_us, results) = mapAccumL compile us branch_fcodes - (branch_results, branch_out_states) = unzip results - -- NB foldl. state is the *left* argument to stateIncUsage - setState $ foldl stateIncUsage state branch_out_states - return branch_results - --- | @forkEval@ takes two blocks of code. --- --- * The first meddles with the environment to set it up as expected by --- the alternatives of a @case@ which does an eval (or gc-possible primop). --- * The second block is the code for the alternatives. --- (plus info for semi-tagging purposes) --- --- @forkEval@ picks up the virtual stack pointer and returns a suitable --- @EndOfBlockInfo@ for the caller to use, together with whatever value --- is returned by the second block. --- --- It uses @initEnvForAlternatives@ to initialise the environment, and --- @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap usage. -forkEval :: EndOfBlockInfo -- For the body - -> Code -- Code to set environment - -> FCode Sequel -- Semi-tagging info to store - -> FCode EndOfBlockInfo -- The new end of block info -forkEval body_eob_info env_code body_code = do - (v, sequel) <- forkEvalHelp body_eob_info env_code body_code - returnFC (EndOfBlockInfo v sequel) - --- A disturbingly complicated function -forkEvalHelp :: EndOfBlockInfo -- For the body - -> Code -- Code to set environment - -> FCode a -- The code to do after the eval - -> FCode (VirtualSpOffset, -- Sp - a) -- Result of the FCode -forkEvalHelp body_eob_info env_code body_code = do - info <- getInfoDown - us <- newUniqSupply - state <- getState - - let info_body = info { cgd_eob = body_eob_info } - (_, env_state) = doFCode env_code info_body - (state {cgs_uniqs = us}) - state_for_body = (initCgState (cgs_uniqs env_state)) - { cgs_binds = binds_for_body, - cgs_stk_usg = stk_usg_for_body } - binds_for_body = nukeVolatileBinds (cgs_binds env_state) - stk_usg_from_env = cgs_stk_usg env_state - virtSp_from_env = virtSp stk_usg_from_env - stk_usg_for_body = stk_usg_from_env { realSp = virtSp_from_env, - hwSp = virtSp_from_env } - (value_returned, state_at_end_return) - = doFCode body_code info_body state_for_body - - -- The code coming back should consist only of nested declarations, - -- notably of the return vector! - ASSERT( isNilOL (cgs_stmts state_at_end_return) ) - setState $ state `stateIncUsageEval` state_at_end_return - return (virtSp_from_env, value_returned) - --- ---------------------------------------------------------------------------- --- Combinators for emitting code - -nopC :: Code -nopC = return () - -whenC :: Bool -> Code -> Code -whenC True code = code -whenC False _ = nopC - --- Corresponds to 'emit' in new code generator with a smart constructor --- from cmm/MkGraph.hs -stmtC :: CmmStmt -> Code -stmtC stmt = emitCgStmt (CgStmt stmt) - -labelC :: BlockId -> Code -labelC id = emitCgStmt (CgLabel id) - -newLabelC :: FCode BlockId -newLabelC = do - u <- newUnique - return $ mkBlockId u - --- Emit code, eliminating no-ops -checkedAbsC :: CmmStmt -> Code -checkedAbsC stmt = emitStmts $ if isNopStmt stmt then nilOL else unitOL stmt - -stmtsC :: [CmmStmt] -> Code -stmtsC stmts = emitStmts $ toOL stmts - --- Emit code; no no-op checking -emitStmts :: CmmStmts -> Code -emitStmts stmts = emitCgStmts $ fmap CgStmt stmts - --- forkLabelledCode is for emitting a chunk of code with a label, outside --- of the current instruction stream. -forkLabelledCode :: Code -> FCode BlockId -forkLabelledCode code = getCgStmts code >>= forkCgStmts - -emitCgStmt :: CgStmt -> Code -emitCgStmt stmt = do - state <- getState - setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } - -emitDecl :: CmmDecl -> Code -emitDecl decl = do - state <- getState - setState $ state { cgs_tops = cgs_tops state `snocOL` decl } - -emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code -emitProc mb_info lbl [] blocks = do - let proc_block = CmmProc infos lbl (ListGraph blocks) - state <- getState - setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } - where - infos = case (blocks,mb_info) of - (b:_, Just info) -> mapSingleton (blockId b) info - _other -> mapEmpty - -emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args" - --- Emit a procedure whose body is the specified code; no info table -emitSimpleProc :: CLabel -> Code -> Code -emitSimpleProc lbl code = do - stmts <- getCgStmts code - blks <- cgStmtsToBlocks stmts - emitProc Nothing lbl [] blks - --- Get all the CmmTops (there should be no stmts) --- Return a single Cmm which may be split from other Cmms by --- object splitting (at a later stage) -getCmm :: Code -> FCode CmmGroup -getCmm code = do - state1 <- getState - ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - setState $ state2 { cgs_tops = cgs_tops state1 } - return (fromOL (cgs_tops state2)) - --- ---------------------------------------------------------------------------- --- CgStmts - --- These functions deal in terms of CgStmts, which is an abstract type --- representing the code in the current proc. - --- emit CgStmts into the current instruction stream -emitCgStmts :: CgStmts -> Code -emitCgStmts stmts = do - state <- getState - setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } - --- emit CgStmts outside the current instruction stream, and return a label -forkCgStmts :: CgStmts -> FCode BlockId -forkCgStmts stmts = do - id <- newLabelC - emitCgStmt (CgFork id stmts) - return id - --- turn CgStmts into [CmmBasicBlock], for making a new proc. -cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock] -cgStmtsToBlocks stmts = do - id <- newLabelC - return (flattenCgStmts id stmts) - --- collect the code emitted by an FCode computation -getCgStmts' :: FCode a -> FCode (a, CgStmts) -getCgStmts' fcode = do - state1 <- getState - (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL }) - setState $ state2 { cgs_stmts = cgs_stmts state1 } - return (a, cgs_stmts state2) - -getCgStmts :: FCode a -> FCode CgStmts -getCgStmts fcode = do - (_,stmts) <- getCgStmts' fcode - return stmts - --- Simple ways to construct CgStmts: -noCgStmts :: CgStmts -noCgStmts = nilOL - -oneCgStmt :: CmmStmt -> CgStmts -oneCgStmt stmt = unitOL (CgStmt stmt) - -consCgStmt :: CmmStmt -> CgStmts -> CgStmts -consCgStmt stmt stmts = CgStmt stmt `consOL` stmts - --- ---------------------------------------------------------------------------- --- Get the current module name - -getModuleName :: FCode Module -getModuleName = do - info <- getInfoDown - return (cgd_mod info) - --- ---------------------------------------------------------------------------- --- Get/set the end-of-block info - -setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code -setEndOfBlockInfo eob_info code = do - info <- getInfoDown - withInfoDown code (info {cgd_eob = eob_info}) - -getEndOfBlockInfo :: FCode EndOfBlockInfo -getEndOfBlockInfo = do - info <- getInfoDown - return (cgd_eob info) - --- ---------------------------------------------------------------------------- --- Get/set the current SRT label - --- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to --- the nested bindings via the monad. - -getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do - info <- getInfoDown - return (cgd_srt_lbl info) - -setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code = do - info <- getInfoDown - withInfoDown code (info { cgd_srt_lbl = srt_lbl}) - -getSRT :: FCode SRT -getSRT = do - info <- getInfoDown - return (cgd_srt info) - -setSRT :: SRT -> FCode a -> FCode a -setSRT srt code = do - info <- getInfoDown - withInfoDown code (info { cgd_srt = srt}) - --- ---------------------------------------------------------------------------- --- Get/set the current ticky counter label - -getTickyCtrLabel :: FCode CLabel -getTickyCtrLabel = do - info <- getInfoDown - return (cgd_ticky info) - -setTickyCtrLabel :: CLabel -> Code -> Code -setTickyCtrLabel ticky code = do - info <- getInfoDown - withInfoDown code (info {cgd_ticky = ticky}) -\end{code} diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs deleted file mode 100644 index 0e642cba59..0000000000 --- a/compiler/codeGen/CgParallel.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow -2006 --- --- Code generation relaed to GpH --- (a) parallel --- (b) GranSim --- ------------------------------------------------------------------------------ - -module CgParallel( - staticGranHdr,staticParHdr, - granFetchAndReschedule, granYield, - doGranAllocate - ) where - -import CgMonad -import CgCallConv -import DynFlags -import Id -import OldCmm -import Outputable -import SMRep - -import Control.Monad - -staticParHdr :: [CmmLit] --- Parallel header words in a static closure -staticParHdr = [] - --------------------------------------------------------- --- GranSim stuff --------------------------------------------------------- - -staticGranHdr :: [CmmLit] --- Gransim header words in a static closure -staticGranHdr = [] - -doGranAllocate :: CmmExpr -> Code --- macro DO_GRAN_ALLOCATE -doGranAllocate _hp - = do dflags <- getDynFlags - when (gopt Opt_GranMacros dflags) $ panic "doGranAllocate" - - - -------------------------- -granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code --- Emit code for simulating a fetch and then reschedule. -granFetchAndReschedule regs node_reqd - = do dflags <- getDynFlags - let liveness = mkRegLiveness dflags regs 0 0 - when (gopt Opt_GranMacros dflags && - (node `elem` map snd regs || node_reqd)) $ - do fetch - reschedule liveness node_reqd - -fetch :: FCode () -fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai - -reschedule :: StgWord -> Bool -> Code -reschedule _liveness _node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - - -------------------------- --- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It --- allows to context-switch at places where @node@ is not alive (it uses the --- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit --- this kind of macro at the beginning of the following kinds of basic bocks: --- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally --- we use @fetchAndReschedule@ at a slow entry code. --- \item Fast entry code (see @CgClosure.lhs@). --- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will --- be turned into separate functions. - -granYield :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code - -granYield regs node_reqd - = do dflags <- getDynFlags - let liveness = mkRegLiveness dflags regs 0 0 - when (gopt Opt_GranMacros dflags && node_reqd) $ yield liveness - -yield :: StgWord -> Code -yield _liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD - -- [mkIntCLit (I# (word2Int# liveness_mask))]) - - diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs deleted file mode 100644 index 6185a2b07f..0000000000 --- a/compiler/codeGen/CgPrimOp.hs +++ /dev/null @@ -1,1177 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for PrimOps. --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CgPrimOp ( - cgPrimOp - ) where - -import BasicTypes -import ForeignCall -import ClosureInfo -import StgSyn -import CgForeignCall -import CgBindery -import CgMonad -import CgHeapery -import CgInfoTbls -import CgTicky -import CgProf -import CgUtils -import OldCmm -import CLabel -import OldCmmUtils -import PrimOp -import SMRep -import Module -import Outputable -import DynFlags -import FastString - -import Control.Monad -import Data.Bits - --- --------------------------------------------------------------------------- --- Code generation for PrimOps - -cgPrimOp :: [CmmFormal] -- where to put the results - -> PrimOp -- the op - -> [StgArg] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code - -cgPrimOp results op args live - = do dflags <- getDynFlags - arg_exprs <- getArgAmodes args - let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] - emitPrimOp dflags results op non_void_args live - - -emitPrimOp :: DynFlags - -> [CmmFormal] -- where to put the results - -> PrimOp -- the op - -> [CmmExpr] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code - --- First we handle various awkward cases specially. The remaining --- easy cases are then handled by translateOp, defined below. - -emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _ -{- - With some bit-twiddling, we can define int{Add,Sub}Czh portably in - C, and without needing any comparisons. This may not be the - fastest way to do it - if you have better code, please send it! --SDM - - Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. - overflow), we just convert to big integers and try again. This - could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - Wading through the mass of bracketry, it seems to reduce to: - c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) - --} - = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), - CmmAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - -emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _ -{- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } - - c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) --} - = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), - CmmAssign (CmmLocal res_c) $ - CmmMachOp (mo_wordUShr dflags) [ - CmmMachOp (mo_wordAnd dflags) [ - CmmMachOp (mo_wordXor dflags) [aa,bb], - CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] - ], - mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) - ] - ] - - -emitPrimOp _ [res] ParOp [arg] live - = do - -- for now, just implement this in a C function - -- later, we might want to inline it. - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [CmmHinted res NoHint] - (CmmCallee newspark CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) - , (CmmHinted arg AddrHint) ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - where - newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) - -emitPrimOp dflags [res] SparkOp [arg] live = do - -- returns the value of arg in res. We're going to therefore - -- refer to arg twice (once to pass to newSpark(), and once to - -- assign to res), so put it in a temporary. - tmp <- newTemp (bWord dflags) - stmtC (CmmAssign (CmmLocal tmp) arg) - - vols <- getVolatileRegs live - res' <- newTemp (bWord dflags) - emitForeignCall' PlayRisky - [CmmHinted res' NoHint] - (CmmCallee newspark CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) - , (CmmHinted arg AddrHint) ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) - where - newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) - -emitPrimOp dflags [res] GetCCSOfOp [arg] _live - = stmtC (CmmAssign (CmmLocal res) val) - where - val - | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) - | otherwise = CmmLit (zeroCLit dflags) - -emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live - = stmtC (CmmAssign (CmmLocal res) curCCS) - -emitPrimOp dflags [res] ReadMutVarOp [mutv] _ - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags))) - -emitPrimOp dflags [] WriteMutVarOp [mutv,var] live - = do stmtC (CmmStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var) - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [{-no results-}] - (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) - , (CmmHinted mutv AddrHint) ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - --- #define sizzeofByteArrayzh(r,a) \ --- r = ((StgArrWords *)(a))->bytes -emitPrimOp dflags [res] SizeofByteArrayOp [arg] _ - = stmtC $ - CmmAssign (CmmLocal res) - (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) - --- #define sizzeofMutableByteArrayzh(r,a) \ --- r = ((StgArrWords *)(a))->bytes -emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] live - = emitPrimOp dflags [res] SizeofByteArrayOp [arg] live - - --- #define touchzh(o) /* nothing */ -emitPrimOp _ [] TouchOp [_] _ - = nopC - --- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp dflags [res] ByteArrayContents_Char [arg] _ - = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))) - --- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp dflags [res] StableNameToIntOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))) - --- #define eqStableNamezh(r,sn1,sn2) \ --- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ - cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), - cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) - ])) - - -emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])) - --- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp _ [res] AddrToAnyOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) arg) - --- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) --- Note: argument may be tagged! -emitPrimOp dflags [res] DataToTagOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))) - -{- Freezing arrays-of-ptrs requires changing an info table, for the - benefit of the generational collector. It needs to scavenge mutable - objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} - --- #define unsafeFreezzeArrayzh(r,a) --- { --- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); --- r = a; --- } -emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] _ - = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), - CmmAssign (CmmLocal res) arg ] -emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] _ - = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), - CmmAssign (CmmLocal res) arg ] - --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) arg) - -emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] live = - doCopyArrayOp src src_off dst dst_off n live -emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = - doCopyMutableArrayOp src src_off dst dst_off n live -emitPrimOp _ [res] CloneArrayOp [src,src_off,n] live = - emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] live = - emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live -emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] live = - emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp _ [res] ThawArrayOp [src,src_off,n] live = - emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live - -emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live = - doCopyArrayOp src src_off dst dst_off n live -emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live = - doCopyMutableArrayOp src src_off dst dst_off n live - --- Reading/writing pointer arrays - -emitPrimOp _ [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp _ [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp dflags [res] SizeofArrayOp [arg] _ - = stmtC $ CmmAssign (CmmLocal res) - (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags)) -emitPrimOp dflags [res] SizeofMutableArrayOp [arg] live - = emitPrimOp dflags [res] SizeofArrayOp [arg] live -emitPrimOp dflags [res] SizeofArrayArrayOp [arg] live - = emitPrimOp dflags [res] SizeofArrayOp [arg] live -emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live - = emitPrimOp dflags [res] SizeofArrayOp [arg] live - --- IndexXXXoffAddr - -emitPrimOp dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args - --- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. - -emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args - --- IndexXXXArray - -emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args - --- ReadXXXArray, identical to IndexXXXArray. - -emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args -emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args -emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args -emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args - --- WriteXXXoffAddr - -emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args -emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args -emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args -emitPrimOp dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args - --- WriteXXXArray - -emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args -emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args -emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args -emitPrimOp dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args -emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args -emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args -emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args - --- Copying and setting byte arrays - -emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = - doCopyByteArrayOp src src_off dst dst_off n live -emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = - doCopyMutableByteArrayOp src src_off dst dst_off n live -emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live = - doSetByteArrayOp ba off len c live - --- Population count. --- The type of the primop takes a Word#, so we have to be careful to narrow --- to the correct width before calling the primop. Otherwise this can result --- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the --- argument is <=0xff. -emitPrimOp dflags [res] PopCnt8Op [w] live = - emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live -emitPrimOp dflags [res] PopCnt16Op [w] live = - emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live -emitPrimOp dflags [res] PopCnt32Op [w] live = - emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live -emitPrimOp dflags [res] PopCnt64Op [w] live = - emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live -emitPrimOp dflags [res] PopCntOp [w] live = - emitPopCntCall res w (wordWidth dflags) live - --- The rest just translate straightforwardly -emitPrimOp dflags [res] op [arg] _ - | nopOp op - = stmtC (CmmAssign (CmmLocal res) arg) - - | Just (mop,rep) <- narrowOp op - = stmtC (CmmAssign (CmmLocal res) $ - CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]) - -emitPrimOp dflags [res] op args live - | Just prim <- callishOp op - = do vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [CmmHinted res NoHint] - (CmmPrim prim Nothing) - [CmmHinted a NoHint | a<-args] -- ToDo: hints? - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - - | Just mop <- translateOp dflags op - = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in - stmtC stmt - -emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ - = let genericImpl - = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]), - CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl)) - [CmmHinted res_q NoHint, - CmmHinted res_r NoHint] - [CmmHinted arg_x NoHint, - CmmHinted arg_y NoHint] - CmmMayReturn - in stmtC stmt -emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ - = let genericImpl - = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]), - CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl)) - [CmmHinted res_q NoHint, - CmmHinted res_r NoHint] - [CmmHinted arg_x NoHint, - CmmHinted arg_y NoHint] - CmmMayReturn - in stmtC stmt -emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ - = do let ty = cmmExprType dflags arg_x_high - shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] - shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] - ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] - minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] - times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - zero = lit 0 - one = lit 1 - negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) - lit i = CmmLit (CmmInt i (wordWidth dflags)) - f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] - f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, - CmmAssign (CmmLocal res_r) high] - f i acc high low = - do roverflowedBit <- newLocalReg ty - rhigh' <- newLocalReg ty - rhigh'' <- newLocalReg ty - rlow' <- newLocalReg ty - risge <- newLocalReg ty - racc' <- newLocalReg ty - let high' = CmmReg (CmmLocal rhigh') - isge = CmmReg (CmmLocal risge) - overflowedBit = CmmReg (CmmLocal roverflowedBit) - let this = [CmmAssign (CmmLocal roverflowedBit) - (shr high negone), - CmmAssign (CmmLocal rhigh') - (or (shl high one) (shr low negone)), - CmmAssign (CmmLocal rlow') - (shl low one), - CmmAssign (CmmLocal risge) - (or (overflowedBit `ne` zero) - (high' `ge` arg_y)), - CmmAssign (CmmLocal rhigh'') - (high' `minus` (arg_y `times` isge)), - CmmAssign (CmmLocal racc') - (or (shl acc one) isge)] - rest <- f (i - 1) (CmmReg (CmmLocal racc')) - (CmmReg (CmmLocal rhigh'')) - (CmmReg (CmmLocal rlow')) - return (this ++ rest) - genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low - let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl)) - [CmmHinted res_q NoHint, - CmmHinted res_r NoHint] - [CmmHinted arg_x_high NoHint, - CmmHinted arg_x_low NoHint, - CmmHinted arg_y NoHint] - CmmMayReturn - stmtC stmt - -emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ - = do r1 <- newLocalReg (cmmExprType dflags arg_x) - r2 <- newLocalReg (cmmExprType dflags arg_x) - -- This generic implementation is very simple and slow. We might - -- well be able to do better, but for now this at least works. - let genericImpl - = [CmmAssign (CmmLocal r1) - (add (bottomHalf arg_x) (bottomHalf arg_y)), - CmmAssign (CmmLocal r2) - (add (topHalf (CmmReg (CmmLocal r1))) - (add (topHalf arg_x) (topHalf arg_y))), - CmmAssign (CmmLocal res_h) - (topHalf (CmmReg (CmmLocal r2))), - CmmAssign (CmmLocal res_l) - (or (toTopHalf (CmmReg (CmmLocal r2))) - (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl)) - [CmmHinted res_h NoHint, - CmmHinted res_l NoHint] - [CmmHinted arg_x NoHint, - CmmHinted arg_y NoHint] - CmmMayReturn - stmtC stmt -emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _ - = do let t = cmmExprType dflags arg_x - xlyl <- liftM CmmLocal $ newLocalReg t - xlyh <- liftM CmmLocal $ newLocalReg t - xhyl <- liftM CmmLocal $ newLocalReg t - r <- liftM CmmLocal $ newLocalReg t - -- This generic implementation is very simple and slow. We might - -- well be able to do better, but for now this at least works. - let genericImpl - = [CmmAssign xlyl - (mul (bottomHalf arg_x) (bottomHalf arg_y)), - CmmAssign xlyh - (mul (bottomHalf arg_x) (topHalf arg_y)), - CmmAssign xhyl - (mul (topHalf arg_x) (bottomHalf arg_y)), - CmmAssign r - (sum [topHalf (CmmReg xlyl), - bottomHalf (CmmReg xhyl), - bottomHalf (CmmReg xlyh)]), - CmmAssign (CmmLocal res_l) - (or (bottomHalf (CmmReg xlyl)) - (toTopHalf (CmmReg r))), - CmmAssign (CmmLocal res_h) - (sum [mul (topHalf arg_x) (topHalf arg_y), - topHalf (CmmReg xhyl), - topHalf (CmmReg xlyh), - topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] - bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] - add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] - sum = foldl1 add - mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] - or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - (wordWidth dflags)) - hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) - stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl)) - [CmmHinted res_h NoHint, - CmmHinted res_l NoHint] - [CmmHinted arg_x NoHint, - CmmHinted arg_y NoHint] - CmmMayReturn - stmtC stmt - -emitPrimOp _ _ op _ _ - = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) - -newLocalReg :: CmmType -> FCode LocalReg -newLocalReg t = do u <- newUnique - return $ LocalReg u t - --- These PrimOps are NOPs in Cmm - -nopOp :: PrimOp -> Bool -nopOp Int2WordOp = True -nopOp Word2IntOp = True -nopOp Int2AddrOp = True -nopOp Addr2IntOp = True -nopOp ChrOp = True -- Int# and Char# are rep'd the same -nopOp OrdOp = True -nopOp _ = False - --- These PrimOps turn into double casts - -narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width) -narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8) -narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16) -narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) -narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) -narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) -narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) -narrowOp _ = Nothing - --- Native word signless ops - -translateOp :: DynFlags -> PrimOp -> Maybe MachOp -translateOp dflags IntAddOp = Just (mo_wordAdd dflags) -translateOp dflags IntSubOp = Just (mo_wordSub dflags) -translateOp dflags WordAddOp = Just (mo_wordAdd dflags) -translateOp dflags WordSubOp = Just (mo_wordSub dflags) -translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) -translateOp dflags AddrSubOp = Just (mo_wordSub dflags) - -translateOp dflags IntEqOp = Just (mo_wordEq dflags) -translateOp dflags IntNeOp = Just (mo_wordNe dflags) -translateOp dflags WordEqOp = Just (mo_wordEq dflags) -translateOp dflags WordNeOp = Just (mo_wordNe dflags) -translateOp dflags AddrEqOp = Just (mo_wordEq dflags) -translateOp dflags AddrNeOp = Just (mo_wordNe dflags) - -translateOp dflags AndOp = Just (mo_wordAnd dflags) -translateOp dflags OrOp = Just (mo_wordOr dflags) -translateOp dflags XorOp = Just (mo_wordXor dflags) -translateOp dflags NotOp = Just (mo_wordNot dflags) -translateOp dflags SllOp = Just (mo_wordShl dflags) -translateOp dflags SrlOp = Just (mo_wordUShr dflags) - -translateOp dflags AddrRemOp = Just (mo_wordURem dflags) - --- Native word signed ops - -translateOp dflags IntMulOp = Just (mo_wordMul dflags) -translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) -translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) -translateOp dflags IntRemOp = Just (mo_wordSRem dflags) -translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) - - -translateOp dflags IntGeOp = Just (mo_wordSGe dflags) -translateOp dflags IntLeOp = Just (mo_wordSLe dflags) -translateOp dflags IntGtOp = Just (mo_wordSGt dflags) -translateOp dflags IntLtOp = Just (mo_wordSLt dflags) - -translateOp dflags ISllOp = Just (mo_wordShl dflags) -translateOp dflags ISraOp = Just (mo_wordSShr dflags) -translateOp dflags ISrlOp = Just (mo_wordUShr dflags) - --- Native word unsigned ops - -translateOp dflags WordGeOp = Just (mo_wordUGe dflags) -translateOp dflags WordLeOp = Just (mo_wordULe dflags) -translateOp dflags WordGtOp = Just (mo_wordUGt dflags) -translateOp dflags WordLtOp = Just (mo_wordULt dflags) - -translateOp dflags WordMulOp = Just (mo_wordMul dflags) -translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) -translateOp dflags WordRemOp = Just (mo_wordURem dflags) - -translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) -translateOp dflags AddrLeOp = Just (mo_wordULe dflags) -translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) -translateOp dflags AddrLtOp = Just (mo_wordULt dflags) - --- Char# ops - -translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) -translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) -translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) -translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) -translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) -translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) - --- Double ops - -translateOp _ DoubleEqOp = Just (MO_F_Eq W64) -translateOp _ DoubleNeOp = Just (MO_F_Ne W64) -translateOp _ DoubleGeOp = Just (MO_F_Ge W64) -translateOp _ DoubleLeOp = Just (MO_F_Le W64) -translateOp _ DoubleGtOp = Just (MO_F_Gt W64) -translateOp _ DoubleLtOp = Just (MO_F_Lt W64) - -translateOp _ DoubleAddOp = Just (MO_F_Add W64) -translateOp _ DoubleSubOp = Just (MO_F_Sub W64) -translateOp _ DoubleMulOp = Just (MO_F_Mul W64) -translateOp _ DoubleDivOp = Just (MO_F_Quot W64) -translateOp _ DoubleNegOp = Just (MO_F_Neg W64) - --- Float ops - -translateOp _ FloatEqOp = Just (MO_F_Eq W32) -translateOp _ FloatNeOp = Just (MO_F_Ne W32) -translateOp _ FloatGeOp = Just (MO_F_Ge W32) -translateOp _ FloatLeOp = Just (MO_F_Le W32) -translateOp _ FloatGtOp = Just (MO_F_Gt W32) -translateOp _ FloatLtOp = Just (MO_F_Lt W32) - -translateOp _ FloatAddOp = Just (MO_F_Add W32) -translateOp _ FloatSubOp = Just (MO_F_Sub W32) -translateOp _ FloatMulOp = Just (MO_F_Mul W32) -translateOp _ FloatDivOp = Just (MO_F_Quot W32) -translateOp _ FloatNegOp = Just (MO_F_Neg W32) - --- Conversions - -translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) -translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) - -translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) -translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) - -translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) - --- Word comparisons masquerading as more exotic things. - -translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) -translateOp dflags SameMVarOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) -translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) -translateOp dflags SameTVarOp = Just (mo_wordEq dflags) -translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) - -translateOp _ _ = Nothing - --- These primops are implemented by CallishMachOps, because they sometimes --- turn into foreign calls depending on the backend. - -callishOp :: PrimOp -> Maybe CallishMachOp -callishOp DoublePowerOp = Just MO_F64_Pwr -callishOp DoubleSinOp = Just MO_F64_Sin -callishOp DoubleCosOp = Just MO_F64_Cos -callishOp DoubleTanOp = Just MO_F64_Tan -callishOp DoubleSinhOp = Just MO_F64_Sinh -callishOp DoubleCoshOp = Just MO_F64_Cosh -callishOp DoubleTanhOp = Just MO_F64_Tanh -callishOp DoubleAsinOp = Just MO_F64_Asin -callishOp DoubleAcosOp = Just MO_F64_Acos -callishOp DoubleAtanOp = Just MO_F64_Atan -callishOp DoubleLogOp = Just MO_F64_Log -callishOp DoubleExpOp = Just MO_F64_Exp -callishOp DoubleSqrtOp = Just MO_F64_Sqrt - -callishOp FloatPowerOp = Just MO_F32_Pwr -callishOp FloatSinOp = Just MO_F32_Sin -callishOp FloatCosOp = Just MO_F32_Cos -callishOp FloatTanOp = Just MO_F32_Tan -callishOp FloatSinhOp = Just MO_F32_Sinh -callishOp FloatCoshOp = Just MO_F32_Cosh -callishOp FloatTanhOp = Just MO_F32_Tanh -callishOp FloatAsinOp = Just MO_F32_Asin -callishOp FloatAcosOp = Just MO_F32_Acos -callishOp FloatAtanOp = Just MO_F32_Atan -callishOp FloatLogOp = Just MO_F32_Log -callishOp FloatExpOp = Just MO_F32_Exp -callishOp FloatSqrtOp = Just MO_F32_Sqrt - -callishOp _ = Nothing - ------------------------------------------------------------------------------- --- Helpers for translating various minor variants of array indexing. - --- Bytearrays outside the heap; hence non-pointers -doIndexOffAddrOp, doIndexByteArrayOp - :: Maybe MachOp -> CmmType - -> [LocalReg] -> [CmmExpr] -> Code -doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx -doIndexOffAddrOp _ _ _ _ - = panic "CgPrimOp: doIndexOffAddrOp" - -doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx -doIndexByteArrayOp _ _ _ _ - = panic "CgPrimOp: doIndexByteArrayOp" - -doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code -doReadPtrArrayOp res addr idx - = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx - - -doWriteOffAddrOp, doWriteByteArrayOp - :: Maybe MachOp -> CmmType - -> [LocalReg] -> [CmmExpr] -> Code -doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val] - = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val -doWriteOffAddrOp _ _ _ _ - = panic "CgPrimOp: doWriteOffAddrOp" - -doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val] - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast rep addr idx val -doWriteByteArrayOp _ _ _ _ - = panic "CgPrimOp: doWriteByteArrayOp" - -doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code -doWritePtrArrayOp addr idx val - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing (bWord dflags) addr idx val - stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - -- the write barrier. We must write a byte into the mark table: - -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] - stmtC $ CmmStore ( - cmmOffsetExpr dflags - (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) - (loadArrPtrsSize dflags addr)) - (card dflags idx) - ) (CmmLit (CmmInt 1 W8)) - -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) - where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags - -mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType - -> LocalReg -> CmmExpr -> CmmExpr -> Code -mkBasicIndexedRead off Nothing read_rep res base idx - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx)) -mkBasicIndexedRead off (Just cast) read_rep res base idx - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr dflags off read_rep base idx])) - -mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType - -> CmmExpr -> CmmExpr -> CmmExpr -> Code -mkBasicIndexedWrite off Nothing write_rep base idx val - = do dflags <- getDynFlags - stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) val) -mkBasicIndexedWrite off (Just cast) write_rep base idx val - = do dflags <- getDynFlags - stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) (CmmMachOp cast [val])) - --- ---------------------------------------------------------------------------- --- Misc utils - -cmmIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmIndexOffExpr dflags off rep base idx - = cmmIndexExpr dflags (typeWidth rep) (cmmOffsetB dflags base off) idx - -cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmLoadIndexOffExpr dflags off rep base idx - = CmmLoad (cmmIndexOffExpr dflags off rep base idx) rep - -setInfo :: CmmExpr -> CmmExpr -> CmmStmt -setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr - --- ---------------------------------------------------------------------------- --- Copying byte arrays - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'MutableByteArray#', an offset into the destination --- array, and the number of bytes to copy. Copies the given number of --- bytes from the source array to the destination array. -doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -doCopyByteArrayOp = emitCopyByteArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes live = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live - --- | Takes a source 'MutableByteArray#', an offset in the source --- array, a destination 'MutableByteArray#', an offset into the --- destination array, and the number of bytes to copy. Copies the --- given number of bytes from the source array to the destination --- array. -doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -doCopyMutableByteArrayOp = emitCopyByteArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes live = - do dflags <- getDynFlags - emitIfThenElse (cmmEqWord dflags src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) - -emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code) - -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars - -> Code -emitCopyByteArray copy src src_off dst dst_off n live = do - dflags <- getDynFlags - dst_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off - copy src dst dst_p src_p n live - --- ---------------------------------------------------------------------------- --- Setting byte arrays - --- | Takes a 'MutableByteArray#', an offset into the array, a length, --- and a byte, and sets each of the selected bytes in the array to the --- character. -doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -doSetByteArrayOp ba off len c live - = do dflags <- getDynFlags - p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live - --- ---------------------------------------------------------------------------- --- Copying pointer arrays - --- EZY: This code has an unusually high amount of assignTemp calls, seen --- nowhere else in the code generator. This is mostly because these --- "primitive" ops result in a surprisingly large amount of code. It --- will likely be worthwhile to optimize what is emitted here, so that --- our optimization passes don't waste time repeatedly optimizing the --- same bits of code. - --- | Takes a source 'Array#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -doCopyArrayOp = emitCopyArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes live = - do dflags <- getDynFlags - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live - --- | Takes a source 'MutableArray#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -doCopyMutableArrayOp = emitCopyArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes live = - do dflags <- getDynFlags - emitIfThenElse (cmmEqWord dflags src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) - -emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code) - -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars - -> Code -emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do - dflags <- getDynFlags - -- Assign the arguments to temporaries so the code generator can - -- calculate liveness for us. - n <- assignTemp_ n0 - emitIf (cmmNeWord dflags n (CmmLit (mkIntCLit dflags 0))) $ do - src <- assignTemp_ src0 - src_off <- assignTemp_ src_off0 - dst <- assignTemp_ dst0 - dst_off <- assignTemp_ dst_off0 - - -- Set the dirty bit in the header. - stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - - dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags) - dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off - src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) - - copy src dst dst_p src_p bytes live - - -- The base address of the destination card table - dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst) - - emitSetCards dst_off dst_cards_p n live - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it form the source array. -emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr - -> StgLiveVars -> Code -emitCloneArray info_p res_r src0 src_off0 n0 live = do - dflags <- getDynFlags - let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags) - myCapability = cmmSubWord dflags (CmmReg baseReg) - (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags))) - -- Assign the arguments to temporaries so the code generator can - -- calculate liveness for us. - src <- assignTemp_ src0 - src_off <- assignTemp_ src_off0 - n <- assignTemp_ n0 - - card_bytes <- assignTemp $ cardRoundUp dflags n - size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) - words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size - - arr_r <- newTemp (bWord dflags) - emitAllocateCall arr_r myCapability words live - tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags)) - (CmmLit $ mkIntCLit dflags 0) - - let arr = CmmReg (CmmLocal arr_r) - emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + - oFFSET_StgMutArrPtrs_ptrs dflags)) n - stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + - oFFSET_StgMutArrPtrs_size dflags)) size - - dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) - src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) - src_off - - emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) - (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live - - emitMemsetCall (cmmOffsetExprW dflags dst_p n) - (CmmLit (mkIntCLit dflags 1)) - card_bytes - (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) - live - stmtC $ CmmAssign (CmmLocal res_r) arr - --- | Takes and offset in the destination array, the base address of --- the card table, and the number of elements affected (*not* the --- number of cards). The number of elements may not be zero. --- Marks the relevant cards as dirty. -emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitSetCards dst_start dst_cards_start n live = do - dflags <- getDynFlags - start_card <- assignTemp $ card dflags dst_start - let end_card = card dflags (cmmAddWord dflags dst_start n) - emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) - (CmmLit (mkIntCLit dflags 1)) - (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (CmmLit (mkIntCLit dflags 1))) - (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte) - live - --- Convert an element index to a card index -card :: DynFlags -> CmmExpr -> CmmExpr -card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags (mUT_ARR_PTRS_CARD_BITS dflags))) - --- Convert a number of elements to a number of cards, rounding up -cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr -cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)))) - -bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr -bytesToWordsRoundUp dflags e - = cmmQuotWord dflags - (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE dflags - 1)))) - (wordSize dflags) - -wordSize :: DynFlags -> CmmExpr -wordSize dflags = CmmLit (mkIntCLit dflags (wORD_SIZE dflags)) - --- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars - -> Code -emitMemcpyCall dst src n align live = do - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [{-no results-}] - (CmmPrim MO_Memcpy Nothing) - [ (CmmHinted dst AddrHint) - , (CmmHinted src AddrHint) - , (CmmHinted n NoHint) - , (CmmHinted align NoHint) - ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - --- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars - -> Code -emitMemmoveCall dst src n align live = do - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [{-no results-}] - (CmmPrim MO_Memmove Nothing) - [ (CmmHinted dst AddrHint) - , (CmmHinted src AddrHint) - , (CmmHinted n NoHint) - , (CmmHinted align NoHint) - ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - --- | Emit a call to @memset@. The second argument must be a word but --- its value must fit inside an unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars - -> Code -emitMemsetCall dst c n align live = do - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [{-no results-}] - (CmmPrim MO_Memset Nothing) - [ (CmmHinted dst AddrHint) - , (CmmHinted c NoHint) - , (CmmHinted n NoHint) - , (CmmHinted align NoHint) - ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - --- | Emit a call to @allocate@. -emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code -emitAllocateCall res cap n live = do - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [CmmHinted res AddrHint] - (CmmCallee allocate CCallConv) - [ (CmmHinted cap AddrHint) - , (CmmHinted n NoHint) - ] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn - where - allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing - ForeignLabelInExternalPackage IsFunction)) - -emitPopCntCall :: LocalReg -> CmmExpr -> Width -> StgLiveVars -> Code -emitPopCntCall res x width live = do - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [CmmHinted res NoHint] - (CmmPrim (MO_PopCnt width) Nothing) - [(CmmHinted x NoHint)] - (Just vols) - NoC_SRT -- No SRT b/c we do PlayRisky - CmmMayReturn diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs deleted file mode 100644 index c7ed0d50c3..0000000000 --- a/compiler/codeGen/CgProf.hs +++ /dev/null @@ -1,310 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for profiling --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CgProf ( - mkCCostCentre, mkCCostCentreStack, - - -- Cost-centre Profiling - dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, - enterCostCentreThunk, - enterCostCentreFun, - costCentreFrom, - curCCS, storeCurCCS, - emitCostCentreDecl, emitCostCentreStackDecl, - emitSetCCC, - - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate - ) where - -#include "HsVersions.h" - -import ClosureInfo -import CgUtils -import CgMonad -import SMRep - -import OldCmm -import OldCmmUtils -import CLabel - -import qualified Module -import CostCentre -import DynFlags -import FastString -import Module -import Outputable - -import Data.Char -import Control.Monad - ------------------------------------------------------------------------------ --- --- Cost-centre-stack Profiling --- ------------------------------------------------------------------------------ - --- Expression representing the current cost centre stack -curCCS :: CmmExpr -curCCS = CmmReg (CmmGlobal CCCS) - -storeCurCCS :: CmmExpr -> CmmStmt -storeCurCCS e = CmmAssign (CmmGlobal CCCS) e - -mkCCostCentre :: CostCentre -> CmmLit -mkCCostCentre cc = CmmLabel (mkCCLabel cc) - -mkCCostCentreStack :: CostCentreStack -> CmmLit -mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) - -costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure -costCentreFrom dflags cl - = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (bWord dflags) - -staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] --- The profiling header words in a static closure --- Was SET_STATIC_PROF_HDR -staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, - staticLdvInit dflags] - -dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] --- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] - -initUpdFrameProf :: CmmExpr -> Code --- Initialise the profiling field of an update frame -initUpdFrameProf frame_amode - = ifProfiling $ -- frame->header.prof.ccs = CCCS - do dflags <- getDynFlags - stmtC (CmmStore (cmmOffsetB dflags frame_amode (oFFSET_StgHeader_ccs dflags)) curCCS) - -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. - --- ----------------------------------------------------------------------------- --- Recording allocation in a cost centre - --- | Record the allocation of a closure. The CmmExpr is the cost --- centre stack to which to attribute the allocation. -profDynAlloc :: ClosureInfo -> CmmExpr -> Code -profDynAlloc cl_info ccs - = ifProfiling $ - do dflags <- getDynFlags - profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs - --- | Record the allocation of a closure (size is given by a CmmExpr) --- The size must be in words, because the allocation counter in a CCS counts --- in words. --- --- This API is used by the @CCS_ALLOC()@ macro in @.cmm@ code. --- -profAlloc :: CmmExpr -> CmmExpr -> Code -profAlloc words ccs - = ifProfiling $ - do dflags <- getDynFlags - let alloc_rep = typeWidth (rEP_CostCentreStack_mem_alloc dflags) - stmtC (addToMemE alloc_rep - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) - (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $ - [CmmMachOp (mo_wordSub dflags) [words, - mkIntExpr dflags (profHdrSize dflags)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. - --- ----------------------------------------------------------------------- --- Setting the current cost centre on entry to a closure - -enterCostCentreThunk :: CmmExpr -> Code -enterCostCentreThunk closure = - ifProfiling $ do - dflags <- getDynFlags - stmtC $ storeCurCCS (costCentreFrom dflags closure) - -enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code -enterCostCentreFun ccs closure vols = - ifProfiling $ do - if isCurrentCCS ccs - then do dflags <- getDynFlags - emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS") - [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, - CmmHinted (costCentreFrom dflags closure) AddrHint] vols - else return () -- top-level function, nothing to do - -ifProfiling :: Code -> Code -ifProfiling code - = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags then code else nopC - -ifProfilingL :: DynFlags -> [a] -> [a] -ifProfilingL dflags xs - | gopt Opt_SccProfilingOn dflags = xs - | otherwise = [] - --- --------------------------------------------------------------------------- --- Initialising Cost Centres & CCSs - -emitCostCentreDecl - :: CostCentre - -> Code -emitCostCentreDecl cc = do - -- NB. bytesFS: we want the UTF-8 bytes here (#5559) - { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) - ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS - $ Module.moduleName - $ cc_mod cc) - -- All cost centres will be in the main package, since we - -- don't normally use -auto-all or add SCCs to other packages. - -- Hence don't emit the package name in the module here. - ; dflags <- getDynFlags - ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ - showPpr dflags (costCentreSrcSpan cc) - -- XXX going via FastString to get UTF-8 encoding is silly - ; let - is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF - | otherwise = zero dflags - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, - loc, -- char *srcloc, - zero64, -- StgWord64 mem_alloc - zero dflags, -- StgWord time_ticks - is_caf, -- StgInt is_caf - zero dflags -- struct _CostCentre *link - ] - ; emitDataLits (mkCCLabel cc) lits - } - - -emitCostCentreStackDecl - :: CostCentreStack - -> Code -emitCostCentreStackDecl ccs - | Just cc <- maybeSingletonCCS ccs = do - { dflags <- getDynFlags - ; let - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -- - lits = zero dflags - : mkCCostCentre cc - : replicate (sizeof_ccs_words dflags - 2) (zero dflags) - ; emitDataLits (mkCCSLabel ccs) lits - } - | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) - -zero :: DynFlags -> CmmLit -zero dflags = mkIntCLit dflags 0 -zero64 :: CmmLit -zero64 = CmmInt 0 W64 - -sizeof_ccs_words :: DynFlags -> Int -sizeof_ccs_words dflags - -- round up to the next word. - | ms == 0 = ws - | otherwise = ws + 1 - where - (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags - --- --------------------------------------------------------------------------- --- Set the current cost centre stack - -emitSetCCC :: CostCentre -> Bool -> Bool -> Code -emitSetCCC cc tick push - = do dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do tmp <- newTemp (bWord dflags) -- TODO FIXME NOW - pushCostCentre tmp curCCS cc - when tick $ stmtC (bumpSccCount dflags (CmmReg (CmmLocal tmp))) - when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp))) - else nopC - -pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code -pushCostCentre result ccs cc - = emitRtsCallWithResult result AddrHint - rtsPackageId - (fsLit "pushCostCentre") [CmmHinted ccs AddrHint, - CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint] - -bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt -bumpSccCount dflags ccs - = addToMem (typeWidth (rEP_CostCentreStack_scc_count dflags)) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 - ------------------------------------------------------------------------------ --- --- Lag/drag/void stuff --- ------------------------------------------------------------------------------ - --- --- Initial value for the LDV field in a static closure --- -staticLdvInit :: DynFlags -> CmmLit -staticLdvInit = zeroCLit - --- --- Initial value of the LDV field in a dynamic closure --- -dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp (mo_wordOr dflags) [ - CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], - CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) - ] - --- --- Initialise the LDV word of a new closure --- -ldvRecordCreate :: CmmExpr -> Code -ldvRecordCreate closure = do dflags <- getDynFlags - stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags) - --- --- Called when a closure is entered, marks the closure as having been "used". --- The closure is not an 'inherently used' one. --- The closure is not IND or IND_OLDGEN because neither is considered for LDV --- profiling. --- -ldvEnterClosure :: ClosureInfo -> Code -ldvEnterClosure closure_info - = do dflags <- getDynFlags - let tag = funTag dflags closure_info - ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) - -- don't forget to substract node's tag - -ldvEnter :: CmmExpr -> Code --- Argument is a closure pointer -ldvEnter cl_ptr = do - dflags <- getDynFlags - let - -- don't forget to substract node's tag - ldv_wd = ldvWord dflags cl_ptr - new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) - ifProfiling $ - -- if (era > 0) { - -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | - -- era | LDV_STATE_USE } - emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) - (stmtC (CmmStore ldv_wd new_ldv_wd)) - -loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) (cInt dflags)] - -ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns --- the address of the LDV word in the closure -ldvWord dflags closure_ptr - = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) - diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs deleted file mode 100644 index 2f7bdfc083..0000000000 --- a/compiler/codeGen/CgStackery.lhs +++ /dev/null @@ -1,371 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CgStackery]{Stack management functions} - -Stack-twiddling operations, which are pretty low-down and grimy. -(This is the module that knows all about stack layouts, etc.) - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgStackery ( - spRel, getVirtSp, getRealSp, setRealSp, - setRealAndVirtualSp, getSpRelOffset, - - allocPrimStack, allocStackTop, deAllocStackTop, - adjustStackHW, getFinalStackHW, - setStackFrame, getStackFrame, - mkVirtStkOffsets, mkStkAmodes, - freeStackSlots, - pushUpdateFrame, pushBHUpdateFrame, emitPushUpdateFrame, - ) where - -#include "HsVersions.h" - -import CgMonad -import CgUtils -import CgProf -import ClosureInfo( CgRep(..), cgRepSizeW ) -import SMRep -import OldCmm -import OldCmmUtils -import CLabel -import DynFlags -import Util -import OrdList -import Outputable - -import Control.Monad -import Data.List -\end{code} - -%************************************************************************ -%* * -\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage} -%* * -%************************************************************************ - -spRel is a little function that abstracts the stack direction. Note that most -of the code generator is dependent on the stack direction anyway, so -changing this on its own spells certain doom. ToDo: remove? - - THIS IS DIRECTION SENSITIVE! - -Stack grows down, positive virtual offsets correspond to negative -additions to the stack pointer. - -\begin{code} -spRel :: VirtualSpOffset -- virtual offset of Sp - -> VirtualSpOffset -- virtual offset of The Thing - -> WordOff -- integer offset -spRel sp off = sp - off -\end{code} - -@setRealAndVirtualSp@ sets into the environment the offsets of the -current position of the real and virtual stack pointers in the current -stack frame. The high-water mark is set too. It generates no code. -It is used to initialise things at the beginning of a closure body. - -\begin{code} -setRealAndVirtualSp :: VirtualSpOffset -- New real Sp - -> Code - -setRealAndVirtualSp new_sp - = do { stk_usg <- getStkUsage - ; setStkUsage (stk_usg {virtSp = new_sp, - realSp = new_sp, - hwSp = new_sp}) } - -getVirtSp :: FCode VirtualSpOffset -getVirtSp - = do { stk_usg <- getStkUsage - ; return (virtSp stk_usg) } - -getRealSp :: FCode VirtualSpOffset -getRealSp - = do { stk_usg <- getStkUsage - ; return (realSp stk_usg) } - -setRealSp :: VirtualSpOffset -> Code -setRealSp new_real_sp - = do { stk_usg <- getStkUsage - ; setStkUsage (stk_usg {realSp = new_real_sp}) } - -getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr -getSpRelOffset virtual_offset - = do dflags <- getDynFlags - real_sp <- getRealSp - return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset)) -\end{code} - - -%************************************************************************ -%* * -\subsection[CgStackery-layout]{Laying out a stack frame} -%* * -%************************************************************************ - -'mkVirtStkOffsets' is given a list of arguments. The first argument -gets the /largest/ virtual stack offset (remember, virtual offsets -increase towards the top of stack). - -\begin{code} -mkVirtStkOffsets - :: DynFlags - -> VirtualSpOffset -- Offset of the last allocated thing - -> [(CgRep,a)] -- things to make offsets for - -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out) - -mkVirtStkOffsets dflags init_Sp_offset things - = loop init_Sp_offset [] (reverse things) - where - loop offset offs [] = (offset,offs) - loop offset offs ((VoidArg,_):things) = loop offset offs things - -- ignore Void arguments - loop offset offs ((rep,t):things) - = loop thing_slot ((t,thing_slot):offs) things - where - thing_slot = offset + cgRepSizeW dflags rep - -- offset of thing is offset+size, because we're - -- growing the stack *downwards* as the offsets increase. - --- | 'mkStkAmodes' is a higher-level version of --- 'mkVirtStkOffsets'. It starts from the tail-call locations. --- It returns a single list of addressing modes for the stack --- locations, and therefore is in the monad. It /doesn't/ adjust the --- high water mark. - -mkStkAmodes - :: VirtualSpOffset -- Tail call positions - -> [(CgRep,CmmExpr)] -- things to make offsets for - -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word - CmmStmts) -- Assignments to appropriate stk slots - -mkStkAmodes tail_Sp things - = do dflags <- getDynFlags - rSp <- getRealSp - let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things - abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode - | (amode, offset) <- offsets - ] - returnFC (last_Sp_offset, toOL abs_cs) -\end{code} - -%************************************************************************ -%* * -\subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation} -%* * -%************************************************************************ - -Allocate a virtual offset for something. - -\begin{code} -allocPrimStack :: CgRep -> FCode VirtualSpOffset -allocPrimStack rep = do dflags <- getDynFlags - allocPrimStack' dflags rep - -allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset -allocPrimStack' dflags rep - = do { stk_usg <- getStkUsage - ; let free_stk = freeStk stk_usg - ; case find_block free_stk of - Nothing -> do - { let push_virt_sp = virtSp stk_usg + size - ; setStkUsage (stk_usg { virtSp = push_virt_sp, - hwSp = hwSp stk_usg `max` push_virt_sp }) - -- Adjust high water mark - ; return push_virt_sp } - Just slot -> do - { setStkUsage (stk_usg { freeStk = delete_block free_stk slot }) - ; return slot } - } - where - size :: WordOff - size = cgRepSizeW dflags rep - - -- Find_block looks for a contiguous chunk of free slots - -- returning the offset of its topmost word - find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset - find_block [] = Nothing - find_block (slot:slots) - | take size (slot:slots) == [slot..top_slot] - = Just top_slot - | otherwise - = find_block slots - where -- The stack grows downwards, with increasing virtual offsets. - -- Therefore, the address of a multi-word object is the *highest* - -- virtual offset it occupies (top_slot below). - top_slot = slot+size-1 - - delete_block free_stk slot = [ s | s <- free_stk, - (s<=slot-size) || (s>slot) ] - -- Retain slots which are not in the range - -- slot-size+1..slot -\end{code} - -Allocate a chunk ON TOP OF the stack. - -\begin{code} -allocStackTop :: WordOff -> FCode () -allocStackTop size - = do { stk_usg <- getStkUsage - ; let push_virt_sp = virtSp stk_usg + size - ; setStkUsage (stk_usg { virtSp = push_virt_sp, - hwSp = hwSp stk_usg `max` push_virt_sp }) } -\end{code} - -Pop some words from the current top of stack. This is used for -de-allocating the return address in a case alternative. - -\begin{code} -deAllocStackTop :: WordOff -> FCode () -deAllocStackTop size - = do { stk_usg <- getStkUsage - ; let pop_virt_sp = virtSp stk_usg - size - ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) } -\end{code} - -\begin{code} -adjustStackHW :: VirtualSpOffset -> Code -adjustStackHW offset - = do { stk_usg <- getStkUsage - ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) } -\end{code} - -A knot-tying beast. - -\begin{code} -getFinalStackHW :: (VirtualSpOffset -> Code) -> Code -getFinalStackHW fcode - = do { fixC_ (\hw_sp -> do - { fcode hw_sp - ; stk_usg <- getStkUsage - ; return (hwSp stk_usg) }) - ; return () } -\end{code} - -\begin{code} -setStackFrame :: VirtualSpOffset -> Code -setStackFrame offset - = do { stk_usg <- getStkUsage - ; setStkUsage (stk_usg { frameSp = offset }) } - -getStackFrame :: FCode VirtualSpOffset -getStackFrame - = do { stk_usg <- getStkUsage - ; return (frameSp stk_usg) } -\end{code} - - -%******************************************************** -%* * -%* Setting up update frames * -%* * -%******************************************************** - -@pushUpdateFrame@ $updatee$ pushes a general update frame which -points to $updatee$ as the thing to be updated. It is only used -when a thunk has just been entered, so the (real) stack pointers -are guaranteed to be nicely aligned with the top of stack. -@pushUpdateFrame@ adjusts the virtual and tail stack pointers -to reflect the frame pushed. - -\begin{code} -pushUpdateFrame :: CmmExpr -> Code -> Code -pushUpdateFrame updatee code - = pushSpecUpdateFrame mkUpdInfoLabel updatee code - -pushBHUpdateFrame :: CmmExpr -> Code -> Code -pushBHUpdateFrame updatee code - = pushSpecUpdateFrame mkBHUpdInfoLabel updatee code - -pushSpecUpdateFrame :: CLabel -> CmmExpr -> Code -> Code -pushSpecUpdateFrame lbl updatee code - = do { - when debugIsOn $ do - { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; - ; MASSERT(case sequel of { OnStack -> True; _ -> False}) } - ; dflags <- getDynFlags - ; allocStackTop (fixedHdrSize dflags + - sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE dflags) - ; vsp <- getVirtSp - ; setStackFrame vsp - ; frame_addr <- getSpRelOffset vsp - -- The location of the lowest-address - -- word of the update frame itself - - -- NB. we used to set the Sequel to 'UpdateCode' so - -- that we could jump directly to the update code if - -- we know that the next frame on the stack is an - -- update frame. However, the RTS can sometimes - -- change an update frame into something else (see - -- e.g. Note [upd-black-hole] in rts/sm/Scav.c), so we - -- no longer make this assumption. - ; setEndOfBlockInfo (EndOfBlockInfo vsp OnStack) $ - do { emitSpecPushUpdateFrame lbl frame_addr updatee - ; code } - } - -emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code -emitPushUpdateFrame = emitSpecPushUpdateFrame mkUpdInfoLabel - -emitSpecPushUpdateFrame :: CLabel -> CmmExpr -> CmmExpr -> Code -emitSpecPushUpdateFrame lbl frame_addr updatee = do - dflags <- getDynFlags - stmtsC [ -- Set the info word - CmmStore frame_addr (mkLblExpr lbl) - , -- And the updatee - CmmStore (cmmOffsetB dflags frame_addr (off_updatee dflags)) updatee ] - initUpdFrameProf frame_addr - -off_updatee :: DynFlags -> ByteOff -off_updatee dflags - = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgUpdateFrame_updatee dflags -\end{code} - - -%************************************************************************ -%* * -\subsection[CgStackery-free]{Free stack slots} -%* * -%************************************************************************ - -Explicitly free some stack space. - -\begin{code} -freeStackSlots :: [VirtualSpOffset] -> Code -freeStackSlots extra_free - = do { stk_usg <- getStkUsage - ; let all_free = addFreeSlots (freeStk stk_usg) (sort extra_free) - ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free - ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) } - -addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset] --- Merge the two, assuming both are in increasing order -addFreeSlots cs [] = cs -addFreeSlots [] ns = ns -addFreeSlots (c:cs) (n:ns) - | c < n = c : addFreeSlots cs (n:ns) - | otherwise = n : addFreeSlots (c:cs) ns - -trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset]) --- Try to trim back the virtual stack pointer, where there is a --- continuous bunch of free slots at the end of the free list -trim vsp [] = (vsp, []) -trim vsp (slot:slots) - = case trim vsp slots of - (vsp', []) - | vsp' < slot -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots)) - (vsp', []) - | vsp' == slot -> (vsp'-1, []) - | otherwise -> (vsp', [slot]) - (vsp', slots') -> (vsp', slot:slots') -\end{code} diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs deleted file mode 100644 index b78415fffa..0000000000 --- a/compiler/codeGen/CgTailCall.lhs +++ /dev/null @@ -1,509 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% Code generation for tail calls. - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgTailCall ( - cgTailCall, performTailCall, - performReturn, performPrimReturn, - returnUnboxedTuple, ccallReturnUnboxedTuple, - pushUnboxedTuple, - tailCallPrimOp, - tailCallPrimCall, - - pushReturnAddress - ) where - -#include "HsVersions.h" - -import CgMonad -import CgBindery -import CgInfoTbls -import CgCallConv -import CgStackery -import CgHeapery -import CgUtils -import CgTicky -import ClosureInfo -import OldCmm -import OldCmmUtils -import CLabel -import Type -import Id -import StgSyn -import PrimOp -import DynFlags -import Outputable -import Util - -import Control.Monad -import Data.Maybe - ------------------------------------------------------------------------------ --- Tail Calls - -cgTailCall :: Id -> [StgArg] -> Code - --- Here's the code we generate for a tail call. (NB there may be no --- arguments, in which case this boils down to just entering a variable.) --- --- * Put args in the top locations of the stack. --- * Adjust the stack ptr --- * Make R1 point to the function closure if necessary. --- * Perform the call. --- --- Things to be careful about: --- --- * Don't overwrite stack locations before you have finished with --- them (remember you need the function and the as-yet-unmoved --- arguments). --- * Preferably, generate no code to replace x by x on the stack (a --- common situation in tail-recursion). --- * Adjust the stack high water mark appropriately. --- --- Treat unboxed locals exactly like literals (above) except use the addr --- mode for the local instead of (CLit lit) in the assignment. - -cgTailCall fun args - = do { fun_info <- getCgIdInfo fun - - ; if isUnLiftedType (idType fun) - then -- Primitive return - ASSERT( null args ) - do { fun_amode <- idInfoToAmode fun_info - ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } - - else -- Normal case, fun is boxed - do { arg_amodes <- getArgAmodes args - ; performTailCall fun_info arg_amodes noStmts } - } - - --- ----------------------------------------------------------------------------- --- The guts of a tail-call - -performTailCall - :: CgIdInfo -- The function - -> [(CgRep,CmmExpr)] -- Args - -> CmmStmts -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack assignments. - -> Code - -performTailCall fun_info arg_amodes pending_assts - | Just join_sp <- maybeLetNoEscape fun_info - = -- A let-no-escape is slightly different, because we - -- arrange the stack arguments into pointers and non-pointers - -- to make the heap check easier. The tail-call sequence - -- is very similar to returning an unboxed tuple, so we - -- share some code. - do { dflags <- getDynFlags - ; (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes - ; emitSimultaneously (pending_assts `plusStmts` arg_assts) - ; let lbl = enterReturnPtLabel dflags (idUnique (cgIdInfoId fun_info)) - ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) } - - | otherwise - = do { fun_amode <- idInfoToAmode fun_info - ; dflags <- getDynFlags - ; let assignSt = CmmAssign nodeReg fun_amode - node_asst = oneStmt assignSt - node_live = Just [node] - (opt_node_asst, opt_node_live) - | nodeMustPointToIt dflags lf_info = (node_asst, node_live) - | otherwise = (noStmts, Just []) - ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - - ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of - - -- Node must always point to things we enter - EnterIt -> do - { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) - enterClosure = stmtC (CmmJump target node_live) - -- If this is a scrutinee - -- let's check if the closure is a constructor - -- so we can directly jump to the alternatives switch - -- statement. - jumpInstr = getEndOfBlockInfo >>= - maybeSwitchOnCons dflags enterClosure - ; doFinalJump sp False jumpInstr } - - -- A function, but we have zero arguments. It is already in WHNF, - -- so we can just return it. - -- As with any return, Node must point to it. - ReturnIt -> do - { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False $ emitReturnInstr node_live } - - -- A real constructor. Don't bother entering it, - -- just do the right sort of return instead. - -- As with any return, Node must point to it. - ReturnCon _ -> do - { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False $ emitReturnInstr node_live } - - JumpToIt lbl -> do - { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) - ; doFinalJump sp False $ jumpToLbl lbl opt_node_live } - - -- A slow function call via the RTS apply routines - -- Node must definitely point to the thing - SlowCall -> do - { when (not (null arg_amodes)) $ do - { if (isKnownFun lf_info) - then tickyKnownCallTooFewArgs - else tickyUnknownCall - ; tickySlowCallPat (map fst arg_amodes) - } - - ; let (apply_lbl, args, extra_args) - = constructSlowCall arg_amodes - - ; directCall sp apply_lbl args extra_args node_live - (node_asst `plusStmts` pending_assts) - - } - - -- A direct function call (possibly with some left-over arguments) - DirectEntry lbl arity -> do - { if arity == length arg_amodes - then tickyKnownCallExact - else do tickyKnownCallExtraArgs - tickySlowCallPat (map fst (drop arity arg_amodes)) - - ; let - -- The args beyond the arity go straight on the stack - (arity_args, extra_args) = splitAt arity arg_amodes - - ; directCall sp lbl arity_args extra_args opt_node_live - (opt_node_asst `plusStmts` pending_assts) - } - } - where - fun_id = cgIdInfoId fun_info - fun_name = idName fun_id - lf_info = cgIdInfoLF fun_info - fun_has_cafs = idCafInfo fun_id - untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)) - -- Test if closure is a constructor - maybeSwitchOnCons dflags enterClosure eob - | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, - not (gopt Opt_SccProfilingOn dflags) - -- we can't shortcut when profiling is on, because we have - -- to enter a closure to mark it as "used" for LDV profiling - = do { is_constr <- newLabelC - -- Is the pointer tagged? - -- Yes, jump to switch statement - ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) - is_constr) - -- No, enter the closure. - ; enterClosure - ; labelC is_constr - ; stmtC (CmmJump (entryCode dflags $ - CmmLit (CmmLabel lbl)) (Just [node])) - } -{- - -- This is a scrutinee for a case expression - -- so let's see if we can directly inspect the closure - | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob - = do { no_cons <- newLabelC - -- Both the NCG and gcc optimize away the temp - ; z <- newTemp wordRep - ; stmtC (CmmAssign z tag_expr) - ; let tag = CmmReg z - -- Is the closure a cons? - ; stmtC (CmmCondBranch (cond1 tag) no_cons) - ; stmtC (CmmCondBranch (cond2 tag) no_cons) - -- Yes, jump to switch statement - ; stmtC (CmmJump (CmmLit (CmmLabel lbl))) - ; labelC no_cons - -- No, enter the closure. - ; enterClosure - } --} - -- No case expression involved, enter the closure. - | otherwise - = do { stmtC $ untag_node dflags - ; enterClosure - } - where - --cond1 tag = cmmULtWord tag lowCons - -- More efficient than the above? -{- - tag_expr = cmmGetClosureType (CmmReg nodeReg) - cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0)) - cond2 tag = cmmUGtWord tag highCons - lowCons = CmmLit (mkIntCLit 1) - -- CONSTR - highCons = CmmLit (mkIntCLit 8) - -- CONSTR_NOCAF_STATIC (from ClosureType.h) --} - -directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] - -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts - -> Code -directCall sp lbl args extra_args live_node assts = do - dflags <- getDynFlags - let - -- First chunk of args go in registers - (reg_arg_amodes, stk_args) = assignCallRegs dflags args - - -- Any "extra" arguments are placed in frames on the - -- stack after the other arguments. - slow_stk_args = slowArgs dflags extra_args - - reg_assts = assignToRegs reg_arg_amodes - live_args = map snd reg_arg_amodes - live_regs = Just $ (fromMaybe [] live_node) ++ live_args - -- - (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args) - emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts - doFinalJump final_sp False $ jumpToLbl lbl live_regs - --- ----------------------------------------------------------------------------- --- The final clean-up before we do a jump at the end of a basic block. --- This code is shared by tail-calls and returns. - -doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code -doFinalJump final_sp is_let_no_escape jump_code - = do { -- Adjust the high-water mark if necessary - adjustStackHW final_sp - - -- Push a return address if necessary (after the assignments - -- above, in case we clobber a live stack location) - -- - -- DONT push the return address when we're about to jump to a - -- let-no-escape: the final tail call in the let-no-escape - -- will do this. - ; eob <- getEndOfBlockInfo - ; whenC (not is_let_no_escape) (pushReturnAddress eob) - - -- Final adjustment of Sp/Hp - ; adjustSpAndHp final_sp - - -- and do the jump - ; jump_code } - --- ---------------------------------------------------------------------------- --- A general return (just a special case of doFinalJump, above) - -performReturn :: Code -- The code to execute to actually do the return - -> Code - -performReturn finish_code - = do { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo - ; doFinalJump args_sp False finish_code } - --- ---------------------------------------------------------------------------- --- Primitive Returns --- Just load the return value into the right register, and return. - -performPrimReturn :: CgRep -> CmmExpr -> Code - --- non-void return value -performPrimReturn rep amode | not (isVoidArg rep) - = do { stmtC (CmmAssign ret_reg amode) - ; performReturn $ emitReturnInstr live_regs } - where - -- careful here as 'dataReturnConvPrim' will panic if given a Void rep - ret_reg@(CmmGlobal r) = dataReturnConvPrim rep - live_regs = Just [r] - --- void return value -performPrimReturn _ _ - = performReturn $ emitReturnInstr (Just []) - - --- --------------------------------------------------------------------------- --- Unboxed tuple returns - --- These are a bit like a normal tail call, except that: --- --- - The tail-call target is an info table on the stack --- --- - We separate stack arguments into pointers and non-pointers, --- to make it easier to leave things in a sane state for a heap check. --- This is OK because we can never partially-apply an unboxed tuple, --- unlike a function. The same technique is used when calling --- let-no-escape functions, because they also can't be partially --- applied. - -returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -returnUnboxedTuple amodes - = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo - ; tickyUnboxedTupleReturn (length amodes) - ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes - ; emitSimultaneously assts - ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) } - -pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing - -> [(CgRep, CmmExpr)] -- amodes of the components - -> FCode (VirtualSpOffset, -- final Sp - CmmStmts, -- assignments (regs+stack) - [GlobalReg]) -- registers used (liveness) - -pushUnboxedTuple sp [] - = return (sp, noStmts, []) -pushUnboxedTuple sp amodes - = do { dflags <- getDynFlags - ; let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes - live_regs = map snd reg_arg_amodes - - -- separate the rest of the args into pointers and non-pointers - (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes - reg_arg_assts = assignToRegs reg_arg_amodes - - -- push ptrs, then nonptrs, on the stack - ; (ptr_sp, ptr_assts) <- mkStkAmodes sp ptr_args - ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args - - ; returnFC (final_sp, - reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts, - live_regs) } - - --- ----------------------------------------------------------------------------- --- Returning unboxed tuples. This is mainly to support _ccall_GC_, where --- we want to do things in a slightly different order to normal: --- --- - push return address --- - adjust stack pointer --- - r = call(args...) --- - assign regs for unboxed tuple (usually just R1 = r) --- - return to continuation --- --- The return address (i.e. stack frame) must be on the stack before --- doing the call in case the call ends up in the garbage collector. --- --- Sadly, the information about the continuation is lost after we push it --- (in order to avoid pushing it again), so we end up doing a needless --- indirect jump (ToDo). - -ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code -ccallReturnUnboxedTuple amodes before_jump - = do { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo - - -- Push a return address if necessary - ; pushReturnAddress eob - ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack) - (do { adjustSpAndHp args_sp - ; before_jump - ; returnUnboxedTuple amodes }) - } - --- ----------------------------------------------------------------------------- --- Calling an out-of-line primop - -tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op - = tailCallPrim (mkRtsPrimOpLabel op) - -tailCallPrimCall :: PrimCall -> [StgArg] -> Code -tailCallPrimCall primcall - = tailCallPrim (mkPrimCallLabel primcall) - -tailCallPrim :: CLabel -> [StgArg] -> Code -tailCallPrim lbl args - = do { dflags <- getDynFlags - -- We're going to perform a normal-looking tail call, - -- except that *all* the arguments will be in registers. - -- Hence the ASSERT( null leftovers ) - ; arg_amodes <- getArgAmodes args - ; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes - live_regs = Just $ map snd arg_regs - jump_to_primop = jumpToLbl lbl live_regs - - ; ASSERT(null leftovers) -- no stack-resident args - emitSimultaneously (assignToRegs arg_regs) - - ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo - ; doFinalJump args_sp False jump_to_primop } - --- ----------------------------------------------------------------------------- --- Return Addresses - --- We always push the return address just before performing a tail call --- or return. The reason we leave it until then is because the stack --- slot that the return address is to go into might contain something --- useful. --- --- If the end of block info is 'CaseAlts', then we're in the scrutinee of a --- case expression and the return address is still to be pushed. --- --- There are cases where it doesn't look necessary to push the return --- address: for example, just before doing a return to a known --- continuation. However, the continuation will expect to find the --- return address on the stack in case it needs to do a heap check. - -pushReturnAddress :: EndOfBlockInfo -> Code - -pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _)) - = do { sp_rel <- getSpRelOffset args_sp - ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) } - -pushReturnAddress _ = nopC - --- ----------------------------------------------------------------------------- --- Misc. - --- Passes no argument to the destination procedure -jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code -jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live - -assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts -assignToRegs reg_args - = mkStmts [ CmmAssign (CmmGlobal reg_id) expr - | (expr, reg_id) <- reg_args ] -\end{code} - - -%************************************************************************ -%* * -\subsection[CgStackery-adjust]{Adjusting the stack pointers} -%* * -%************************************************************************ - -This function adjusts the stack and heap pointers just before a tail -call or return. The stack pointer is adjusted to its final position -(i.e. to point to the last argument for a tail call, or the activation -record for a return). The heap pointer may be moved backwards, in -cases where we overallocated at the beginning of the basic block (see -CgCase.lhs for discussion). - -These functions {\em do not} deal with high-water-mark adjustment. -That's done by functions which allocate stack space. - -\begin{code} -adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr - -> Code -adjustSpAndHp newRealSp - = do { -- Adjust stack, if necessary. - -- NB: the conditional on the monad-carried realSp - -- is out of line (via codeOnly), to avoid a black hole - ; new_sp <- getSpRelOffset newRealSp - ; checkedAbsC (CmmAssign spReg new_sp) -- Will generate no code in the case - ; setRealSp newRealSp -- where realSp==newRealSp - - -- Adjust heap. The virtual heap pointer may be less than the real Hp - -- because the latter was advanced to deal with the worst-case branch - -- of the code, and we may be in a better-case branch. In that case, - -- move the real Hp *back* and retract some ticky allocation count. - ; hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - ; new_hp <- getHpRelOffset vHp - ; checkedAbsC (CmmAssign hpReg new_hp) -- Generates nothing when vHp==rHp - ; tickyAllocHeap (vHp - rHp) -- ...ditto - ; setRealHp vHp - } -\end{code} - diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs deleted file mode 100644 index 898d3f0786..0000000000 --- a/compiler/codeGen/CgTicky.hs +++ /dev/null @@ -1,397 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for ticky-ticky profiling --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgTicky ( - emitTickyCounter, - - tickyDynAlloc, - tickyAllocHeap, - tickyAllocPrim, - tickyAllocThunk, - tickyAllocPAP, - - tickyPushUpdateFrame, - tickyUpdateFrameOmitted, - - tickyEnterDynCon, - tickyEnterStaticCon, - tickyEnterViaNode, - - tickyEnterFun, - tickyEnterThunk, - - tickyUpdateBhCaf, - tickyBlackHole, - tickyUnboxedTupleReturn, tickyVectoredReturn, - tickyReturnOldCon, tickyReturnNewCon, - - tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, - tickyUnknownCall, tickySlowCallPat, - - staticTickyHdr, - ) where - -import ClosureInfo -import CgUtils -import CgMonad - -import OldCmm -import OldCmmUtils -import CLabel - -import Name -import Id -import IdInfo -import BasicTypes -import FastString -import Outputable -import Module - --- Turgid imports for showTypeCategory -import PrelNames -import TcType -import Type -import TyCon - -import DynFlags - -import Data.Maybe - ------------------------------------------------------------------------------ --- --- Ticky-ticky profiling --- ------------------------------------------------------------------------------ - -staticTickyHdr :: [CmmLit] --- krc: not using this right now -- --- in the new version of ticky-ticky, we --- don't change the closure layout. --- leave it defined, though, to avoid breaking --- other things. -staticTickyHdr = [] - -emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code -emitTickyCounter cl_info args on_stk - = ifTicky $ - do { mod_name <- getModuleName - ; dflags <- getDynFlags - ; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name) - ; arg_descr_lit <- newStringCLit arg_descr - ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter --- krc: note that all the fields are I32 now; some were I16 before, --- but the code generator wasn't handling that properly and it led to chaos, --- panic and disorder. - [ mkIntCLit dflags 0, - mkIntCLit dflags (length args),-- Arity - mkIntCLit dflags on_stk, -- Words passed on stack - fun_descr_lit, - arg_descr_lit, - zeroCLit dflags, -- Entry count - zeroCLit dflags, -- Allocs - zeroCLit dflags -- Link - ] } - where - name = closureName cl_info - ticky_ctr_label = mkRednCountsLabel name NoCafRefs - arg_descr = map (showTypeCategory . idType) args - fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name - --- When printing the name of a thing in a ticky file, we want to --- give the module name even for *local* things. We print --- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: DynFlags -> Module -> Name -> String -ppr_for_ticky_name dflags mod_name name - | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug dflags (ppr name) - --- ----------------------------------------------------------------------------- --- Ticky stack frames - -tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") - --- ----------------------------------------------------------------------------- --- Ticky entries - -tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, - tickyEnterStaticThunk, tickyEnterViaNode :: Code -tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") -tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") - -tickyEnterThunk :: ClosureInfo -> Code -tickyEnterThunk cl_info - | isStaticClosure cl_info = tickyEnterStaticThunk - | otherwise = tickyEnterDynThunk - -tickyBlackHole :: Bool{-updatable-} -> Code -tickyBlackHole updatable - = ifTicky (bumpTickyCounter ctr) - where - ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr" - | otherwise = fsLit "UPD_BH_UPDATABLE_ctr" - -tickyUpdateBhCaf :: ClosureInfo -> Code -tickyUpdateBhCaf cl_info - = ifTicky (bumpTickyCounter ctr) - where - ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr" - | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr" - -tickyEnterFun :: ClosureInfo -> Code -tickyEnterFun cl_info - = ifTicky $ - do { dflags <- getDynFlags - ; bumpTickyCounter ctr - ; fun_ctr_lbl <- getTickyCtrLabel - ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) - } - where - ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" - | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr" - -registerTickyCtr :: CLabel -> Code --- Register a ticky counter --- if ( ! f_ct.registeredp ) { --- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ --- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ --- f_ct.registeredp = 1 } -registerTickyCtr ctr_lbl - = do dflags <- getDynFlags - let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq (wordWidth dflags)) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), - CmmLit (mkIntCLit dflags 0)] - register_stmts - = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) - (CmmLoad ticky_entry_ctrs (bWord dflags)) - , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , CmmStore (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) - (CmmLit (mkIntCLit dflags 1)) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) - emitIf test (stmtsC register_stmts) - -tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code -tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") - ; bumpHistogram (fsLit "RET_OLD_hst") arity } -tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") - ; bumpHistogram (fsLit "RET_NEW_hst") arity } - -tickyUnboxedTupleReturn :: Int -> Code -tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } - -tickyVectoredReturn :: Int -> Code -tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") - ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } - --- ----------------------------------------------------------------------------- --- Ticky calls - --- Ticks at a *call site*: -tickyKnownCallTooFewArgs, tickyKnownCallExact, - tickyKnownCallExtraArgs, tickyUnknownCall :: Code -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") -tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") - --- Tick for the call pattern at slow call site (i.e. in addition to --- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) -tickySlowCallPat :: [CgRep] -> Code -tickySlowCallPat _args = return () -{- LATER: (introduces recursive module dependency now). - case callPattern args of - (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) - (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER") - -callPattern :: [CgRep] -> (String,Bool) -callPattern reps - | match == length reps = (chars, True) - | otherwise = (chars, False) - where (_,match) = findMatch reps - chars = map argChar reps - -argChar VoidArg = 'v' -argChar PtrArg = 'p' -argChar NonPtrArg = 'n' -argChar LongArg = 'l' -argChar FloatArg = 'f' -argChar DoubleArg = 'd' --} - --- ----------------------------------------------------------------------------- --- Ticky allocation - -tickyDynAlloc :: ClosureInfo -> Code --- Called when doing a dynamic heap allocation -tickyDynAlloc cl_info - = ifTicky $ - case cl_info of { - ConInfo {} -> tick_alloc_con ; - ClosureInfo { closureLFInfo = lf_info } -> - case lf_info of - LFCon {} -> tick_alloc_con - LFReEntrant {} -> tick_alloc_fun - LFThunk {} -> tick_alloc_thk - -- black hole - _ -> return () } - where - -- will be needed when we fill in stubs - -- _cl_size = closureSize dflags cl_info --- _slop_size = slopSize cl_info - - tick_alloc_thk - | closureUpdReqd cl_info = tick_alloc_up_thk - | otherwise = tick_alloc_se_thk - - -- krc: changed from panic to return () - -- just to get something working - tick_alloc_con = return () - tick_alloc_fun = return () - tick_alloc_up_thk = return () - tick_alloc_se_thk = return () - - -tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code -tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) - -tickyAllocThunk :: CmmExpr -> CmmExpr -> Code -tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) - -tickyAllocPAP :: CmmExpr -> CmmExpr -> Code -tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) - -tickyAllocHeap :: VirtualHpOffset -> Code --- Called when doing a heap check [TICK_ALLOC_HEAP] -tickyAllocHeap hp - = ifTicky $ - do { dflags <- getDynFlags - ; ticky_ctr <- getTickyCtrLabel - ; stmtsC $ - if hp == 0 then [] -- Inside the stmtC to avoid control - else [ -- dependency on the argument - -- Bump the allcoation count in the StgEntCounter - addToMem (typeWidth (rEP_StgEntCounter_allocs dflags)) - (CmmLit (cmmLabelOffB ticky_ctr - (oFFSET_StgEntCounter_allocs dflags))) hp, - -- Bump ALLOC_HEAP_ctr - addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, - -- Bump ALLOC_HEAP_tot - addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } - --- ----------------------------------------------------------------------------- --- Ticky utils - -ifTicky :: Code -> Code -ifTicky code = do dflags <- getDynFlags - if gopt Opt_Ticky dflags then code - else nopC - -addToMemLbl :: Width -> CLabel -> Int -> CmmStmt -addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n - --- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: FastString -> Code -bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) - -bumpTickyCounter' :: CmmLit -> Code --- krc: note that we're incrementing the _entry_count_ field of the ticky counter -bumpTickyCounter' lhs = do dflags <- getDynFlags - stmtC (addToMemLong dflags (CmmLit lhs) 1) - -bumpHistogram :: FastString -> Int -> Code -bumpHistogram _lbl _n --- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong)) - = return () -- TEMP SPJ Apr 07 - -{- -bumpHistogramE :: LitString -> CmmExpr -> Code -bumpHistogramE lbl n - = do t <- newTemp cLong - stmtC (CmmAssign (CmmLocal t) n) - emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $ - stmtC (CmmAssign (CmmLocal t) eight) - stmtC (addToMemLong (cmmIndexExpr cLongWidth - (CmmLit (CmmLabel (mkRtsDataLabel lbl))) - (CmmReg (CmmLocal t))) - 1) - where - eight = CmmLit (CmmInt 8 cLongWidth) --} - ------------------------------------------------------------------- -addToMemLong :: DynFlags -> CmmExpr -> Int -> CmmStmt -addToMemLong dflags = addToMem (cLongWidth dflags) - ------------------------------------------------------------------- --- Showing the "type category" for ticky-ticky profiling - -showTypeCategory :: Type -> Char - {- {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case tcSplitTyConApp_maybe ty of - Nothing -> if isJust (tcSplitFunTy_maybe ty) - then '>' - else '.' - - Just (tycon, _) -> - let utc = getUnique tycon in - if utc == charDataConKey then 'C' - else if utc == intDataConKey then 'I' - else if utc == floatDataConKey then 'F' - else if utc == doubleDataConKey then 'D' - else if utc == charPrimTyConKey then 'c' - else if (utc == intPrimTyConKey || utc == wordPrimTyConKey - || utc == addrPrimTyConKey) then 'i' - else if utc == floatPrimTyConKey then 'f' - else if utc == doublePrimTyConKey then 'd' - else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus - else if isEnumerationTyCon tycon then 'E' - else if isTupleTyCon tycon then 'T' - else if isJust (tyConSingleDataCon_maybe tycon) then 'S' - else if utc == listTyConKey then 'L' - else 'M' -- oh, well... diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 9f9a2cfe26..1f0b82532b 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -6,319 +6,16 @@ -- ----------------------------------------------------------------------------- -module CgUtils ( - addIdReps, - cgLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, - emitIf, emitIfThenElse, - emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - emitRtsCallGen, - assignTemp, assignTemp_, newTemp, - emitSimultaneously, - emitSwitch, emitLitSwitch, - tagToClosure, - - callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, - activeStgRegs, fixStgRegisters, - - cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, - cmmOffsetExprW, cmmOffsetExprB, - cmmRegOffW, cmmRegOffB, - cmmLabelOffW, cmmLabelOffB, - cmmOffsetW, cmmOffsetB, - cmmOffsetLitW, cmmOffsetLitB, - cmmLoadIndexW, - cmmConstrTag, cmmConstrTag1, - - tagForCon, tagCons, isSmallFamily, - cmmUntag, cmmIsTagged, cmmGetTag, - - addToMem, addToMemE, - mkWordCLit, - newStringCLit, newByteStringCLit, - packHalfWordsCLit, - blankWord, - - getSRTInfo - ) where +module CgUtils ( fixStgRegisters ) where #include "HsVersions.h" -import BlockId import CodeGen.Platform -import CgMonad -import TyCon -import DataCon -import Id -import IdInfo -import SMRep import OldCmm -import OldCmmUtils import CLabel -import ForeignCall -import ClosureInfo -import StgSyn (SRT(..)) -import Module -import Literal -import Digraph -import ListSetOps -import Util import DynFlags -import FastString import Outputable -import Data.Char -import Data.Word -import Data.List -import Data.Maybe -import Data.Ord - -------------------------------------------------------------------------- --- --- Random small functions --- -------------------------------------------------------------------------- - -addIdReps :: [Id] -> [(CgRep, Id)] -addIdReps ids = [(idCgRep id, id) | id <- ids] - -------------------------------------------------------------------------- --- --- Literals --- -------------------------------------------------------------------------- - -cgLit :: Literal -> FCode CmmLit -cgLit (MachStr s) = newByteStringCLit (bytesFB s) -cgLit other_lit = do dflags <- getDynFlags - return (mkSimpleLit dflags other_lit) - -mkSimpleLit :: DynFlags -> Literal -> CmmLit -mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) -mkSimpleLit dflags MachNullAddr = zeroCLit dflags -mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachInt64 i) = CmmInt i W64 -mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachWord64 i) = CmmInt i W64 -mkSimpleLit _ (MachFloat r) = CmmFloat r W32 -mkSimpleLit _ (MachDouble r) = CmmFloat r W64 -mkSimpleLit _ (MachLabel fs ms fod) - = CmmLabel (mkForeignLabel fs ms labelSrc fod) - where - -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage -mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr" --- No LitInteger's should be left by the time this is called. CorePrep --- should have converted them all to a real core representation. -mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger" - -mkLtOp :: DynFlags -> Literal -> MachOp --- On signed literals we must do a signed comparison -mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) -mkLtOp _ (MachFloat _) = MO_F_Lt W32 -mkLtOp _ (MachDouble _) = MO_F_Lt W64 -mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) - - ---------------------------------------------------- --- --- Cmm data type functions --- ---------------------------------------------------- - - - -{- - The family size of a data type (the number of constructors) - can be either: - * small, if the family size < 2**tag_bits - * big, otherwise. - - Small families can have the constructor tag in the tag - bits. - Big families only use the tag value 1 to represent - evaluatedness. --} -isSmallFamily :: DynFlags -> Int -> Bool -isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags - -tagForCon :: DynFlags -> DataCon -> ConTagZ -tagForCon dflags con = tag - where - con_tag = dataConTagZ con - fam_size = tyConFamilySize (dataConTyCon con) - tag | isSmallFamily dflags fam_size = con_tag + 1 - | otherwise = 1 - ---Tag an expression, to do: refactor, this appears in some other module. -tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr -tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con) - --------------------------------------------------------------------------- --- --- Incrementing a memory location --- --------------------------------------------------------------------------- - -addToMem :: Width -- rep of the counter - -> CmmExpr -- Address - -> Int -- What to add (a word) - -> CmmStmt -addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width)) - -addToMemE :: Width -- rep of the counter - -> CmmExpr -- Address - -> CmmExpr -- What to add (a word-typed expression) - -> CmmStmt -addToMemE width ptr n - = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n]) - -------------------------------------------------------------------------- --- --- Converting a closure tag to a closure for enumeration types --- (this is the implementation of tagToEnum#). --- -------------------------------------------------------------------------- - -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr -tagToClosure dflags tycon tag - = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (gcWord dflags) - where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs - -------------------------------------------------------------------------- --- --- Conditionals and rts calls --- -------------------------------------------------------------------------- - -emitIf :: CmmExpr -- Boolean - -> Code -- Then part - -> Code --- Emit (if e then x) --- ToDo: reverse the condition to avoid the extra branch instruction if possible --- (some conditionals aren't reversible. eg. floating point comparisons cannot --- be inverted because there exist some values for which both comparisons --- return False, such as NaN.) -emitIf cond then_part - = do { then_id <- newLabelC - ; join_id <- newLabelC - ; stmtC (CmmCondBranch cond then_id) - ; stmtC (CmmBranch join_id) - ; labelC then_id - ; then_part - ; labelC join_id - } - -emitIfThenElse :: CmmExpr -- Boolean - -> Code -- Then part - -> Code -- Else part - -> Code --- Emit (if e then x else y) -emitIfThenElse cond then_part else_part - = do { then_id <- newLabelC - ; join_id <- newLabelC - ; stmtC (CmmCondBranch cond then_id) - ; else_part - ; stmtC (CmmBranch join_id) - ; labelC then_id - ; then_part - ; labelC join_id - } - - --- | Emit code to call a Cmm function. -emitRtsCall - :: PackageId -- ^ package the function is in - -> FastString -- ^ name of function - -> [CmmHinted CmmExpr] -- ^ function args - -> Code -- ^ cmm code - -emitRtsCall pkg fun args = emitRtsCallGen [] pkg fun args Nothing - -- The 'Nothing' says "save all global registers" - -emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Code -emitRtsCallWithVols pkg fun args vols - = emitRtsCallGen [] pkg fun args (Just vols) - -emitRtsCallWithResult - :: LocalReg -> ForeignHint - -> PackageId -> FastString - -> [CmmHinted CmmExpr] -> Code - -emitRtsCallWithResult res hint pkg fun args - = emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing - --- Make a call to an RTS C procedure -emitRtsCallGen - :: [CmmHinted LocalReg] - -> PackageId - -> FastString - -> [CmmHinted CmmExpr] - -> Maybe [GlobalReg] - -> Code -emitRtsCallGen res pkg fun args vols = do - dflags <- getDynFlags - let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols - stmtsC caller_save - stmtC (CmmCall target res args CmmMayReturn) - stmtsC caller_load - where - target = CmmCallee fun_expr CCallConv - fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) - ------------------------------------------------------------------------------ --- --- Caller-Save Registers --- ------------------------------------------------------------------------------ - --- Here we generate the sequence of saves/restores required around a --- foreign call instruction. - --- TODO: reconcile with includes/Regs.h --- * Regs.h claims that BaseReg should be saved last and loaded first --- * This might not have been tickled before since BaseReg is callee save --- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim -callerSaveVolatileRegs :: DynFlags -> Maybe [GlobalReg] - -> ([CmmStmt], [CmmStmt]) -callerSaveVolatileRegs dflags vols = (caller_save, caller_load) - where - platform = targetPlatform dflags - - caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save) - caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save) - - system_regs = [Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery, - {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ] - - regs_to_save = system_regs ++ vol_list - - vol_list = case vols of Nothing -> all_of_em; Just regs -> regs - - all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ] - -- The VNonGcPtr is a lie, but I don't think it matters - ++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ] - ++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ] - ++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ] - - callerSaveGlobalReg reg next - | callerSaves platform reg = - CmmStore (get_GlobalReg_addr dflags reg) - (CmmReg (CmmGlobal reg)) : next - | otherwise = next - - callerRestoreGlobalReg reg next - | callerSaves platform reg = - CmmAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) - (globalRegType dflags reg)) - : next - | otherwise = next - - -- ----------------------------------------------------------------------------- -- Information about global registers @@ -360,457 +57,6 @@ baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg" baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg" -------------------------------------------------------------------------- --- --- Strings generate a top-level data block --- -------------------------------------------------------------------------- - -emitDataLits :: CLabel -> [CmmLit] -> Code --- Emit a data-segment data block -emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits) - -emitRODataLits :: String -> CLabel -> [CmmLit] -> Code --- Emit a read-only data block -emitRODataLits _caller lbl lits - = emitDecl (mkRODataLits lbl lits) - -newStringCLit :: String -> FCode CmmLit --- Make a global definition for the string, --- and return its label -newStringCLit str = newByteStringCLit (map (fromIntegral.ord) str) - -newByteStringCLit :: [Word8] -> FCode CmmLit -newByteStringCLit bytes - = do { uniq <- newUnique - ; let (lit, decl) = mkByteStringCLit uniq bytes - ; emitDecl decl - ; return lit } - -------------------------------------------------------------------------- --- --- Assigning expressions to temporaries --- -------------------------------------------------------------------------- - --- | If the expression is trivial, return it. Otherwise, assign the --- expression to a temporary register and return an expression --- referring to this register. -assignTemp :: CmmExpr -> FCode CmmExpr --- For a non-trivial expression, e, create a local --- variable and assign the expression to it -assignTemp e - | isTrivialCmmExpr e = return e - | otherwise = do dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - stmtC (CmmAssign (CmmLocal reg) e) - return (CmmReg (CmmLocal reg)) - --- | If the expression is trivial and doesn't refer to a global --- register, return it. Otherwise, assign the expression to a --- temporary register and return an expression referring to this --- register. -assignTemp_ :: CmmExpr -> FCode CmmExpr -assignTemp_ e - | isTrivialCmmExpr e && hasNoGlobalRegs e = return e - | otherwise = do - dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - stmtC (CmmAssign (CmmLocal reg) e) - return (CmmReg (CmmLocal reg)) - -newTemp :: CmmType -> FCode LocalReg -newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) } - -------------------------------------------------------------------------- --- --- Building case analysis --- -------------------------------------------------------------------------- - -emitSwitch - :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CgStmts)] -- Tagged branches - -> Maybe CgStmts -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined - -> Code - --- ONLY A DEFAULT BRANCH: no case analysis to do -emitSwitch _ [] (Just stmts) _ _ - = emitCgStmts stmts - --- Right, off we go -emitSwitch tag_expr branches mb_deflt lo_tag hi_tag - = -- Just sort the branches before calling mk_sritch - do { mb_deflt_id <- - case mb_deflt of - Nothing -> return Nothing - Just stmts -> do id <- forkCgStmts stmts; return (Just id) - - ; dflags <- getDynFlags - ; let via_C | HscC <- hscTarget dflags = True - | otherwise = False - - ; stmts <- mk_switch tag_expr (sortBy (comparing fst) branches) - mb_deflt_id lo_tag hi_tag via_C - ; emitCgStmts stmts - } - - -mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] - -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool - -> FCode CgStmts - --- SINGLETON TAG RANGE: no case analysis to do -mk_switch _tag_expr [(tag,stmts)] _ lo_tag hi_tag _via_C - | lo_tag == hi_tag - = ASSERT( tag == lo_tag ) - return stmts - --- SINGLETON BRANCH, NO DEFAULT: no case analysis to do -mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C - = return stmts - -- The simplifier might have eliminated a case - -- so we may have e.g. case xs of - -- [] -> e - -- In that situation we can be sure the (:) case - -- can't happen, so no need to test - --- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do - dflags <- getDynFlags - let - cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag)) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default - return (CmmCondBranch cond deflt `consCgStmt` stmts) - --- ToDo: we might want to check for the two branch case, where one of --- the branches is the tag 0, because comparing '== 0' is likely to be --- more efficient than other kinds of comparison. - --- DENSE TAG RANGE: use a switch statment. --- --- We also use a switch uncoditionally when compiling via C, because --- this will get emitted as a C switch statement and the C compiler --- should do a good job of optimising it. Also, older GCC versions --- (2.95 in particular) have problems compiling the complicated --- if-trees generated by this code, so compiling to a switch every --- time works around that problem. --- -mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C - | use_switch -- Use a switch - = do { dflags <- getDynFlags - ; branch_ids <- mapM forkCgStmts (map snd branches) - ; let - tagged_blk_ids = zip (map fst branches) (map Just branch_ids) - - find_branch :: ConTagZ -> Maybe BlockId - find_branch i = assocDefault mb_deflt tagged_blk_ids i - - -- NB. we have eliminated impossible branches at - -- either end of the range (see below), so the first - -- tag of a real branch is real_lo_tag (not lo_tag). - arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - - switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms - - ; ASSERT(not (all isNothing arms)) - return (oneCgStmt switch_stmt) - } - - -- if we can knock off a bunch of default cases with one if, then do so - | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch)) - branch = CmmCondBranch cond deflt - ; stmts <- mk_switch tag_expr' branches mb_deflt - lowest_branch hi_tag via_C - ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) - } - - | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch)) - branch = CmmCondBranch cond deflt - ; stmts <- mk_switch tag_expr' branches mb_deflt - lo_tag highest_branch via_C - ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) - } - - | otherwise -- Use an if-tree - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - -- To avoid duplication - ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt - lo_tag (mid_tag-1) via_C - ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt - mid_tag hi_tag via_C - ; hi_id <- forkCgStmts hi_stmts - ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag)) - branch_stmt = CmmCondBranch cond hi_id - ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) - } - -- we test (e >= mid_tag) rather than (e < mid_tag), because - -- the former works better when e is a comparison, and there - -- are two tags 0 & 1 (mid_tag == 1). In this case, the code - -- generator can reduce the condition to e itself without - -- having to reverse the sense of the comparison: comparisons - -- can't always be easily reversed (eg. floating - -- pt. comparisons). - where - use_switch = {- pprTrace "mk_switch" ( - ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> - text "branches:" <+> ppr (map fst branches) <+> - text "n_branches:" <+> int n_branches <+> - text "lo_tag:" <+> int lo_tag <+> - text "hi_tag:" <+> int hi_tag <+> - text "real_lo_tag:" <+> int real_lo_tag <+> - text "real_hi_tag:" <+> int real_hi_tag) $ -} - ASSERT( n_branches > 1 && n_tags > 1 ) - n_tags > 2 && (via_C || (dense && big_enough)) - -- up to 4 branches we use a decision tree, otherwise - -- a switch (== jump table in the NCG). This seems to be - -- optimal, and corresponds with what gcc does. - big_enough = n_branches > 4 - dense = n_branches > (n_tags `div` 2) - n_branches = length branches - - -- ignore default slots at each end of the range if there's - -- no default branch defined. - lowest_branch = fst (head branches) - highest_branch = fst (last branches) - - real_lo_tag - | isNothing mb_deflt = lowest_branch - | otherwise = lo_tag - - real_hi_tag - | isNothing mb_deflt = highest_branch - | otherwise = hi_tag - - n_tags = real_hi_tag - real_lo_tag + 1 - - -- INVARIANT: Provided hi_tag > lo_tag (which is true) - -- lo_tag <= mid_tag < hi_tag - -- lo_branches have tags < mid_tag - -- hi_branches have tags >= mid_tag - - (mid_tag,_) = branches !! (n_branches `div` 2) - -- 2 branches => n_branches `div` 2 = 1 - -- => branches !! 1 give the *second* tag - -- There are always at least 2 branches here - - (lo_branches, hi_branches) = span is_lo branches - is_lo (t,_) = t < mid_tag - -assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr) -assignTemp' e - | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) - -emitLitSwitch :: CmmExpr -- Tag to switch on - -> [(Literal, CgStmts)] -- Tagged branches - -> CgStmts -- Default branch (always) - -> Code -- Emit the code --- Used for general literals, whose size might not be a word, --- where there is always a default case, and where we don't know --- the range of values for certain. For simplicity we always generate a tree. --- --- ToDo: for integers we could do better here, perhaps by generalising --- mk_switch and using that. --SDM 15/09/2004 -emitLitSwitch _ [] deflt = emitCgStmts deflt -emitLitSwitch scrut branches deflt_blk - = do { scrut' <- assignTemp scrut - ; deflt_blk_id <- forkCgStmts deflt_blk - ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches) - ; emitCgStmts blk } - -mk_lit_switch :: CmmExpr -> BlockId - -> [(Literal,CgStmts)] - -> FCode CgStmts -mk_lit_switch scrut deflt_blk_id [(lit,blk)] - = do dflags <- getDynFlags - let cmm_lit = mkSimpleLit dflags lit - rep = cmmLitType dflags cmm_lit - ne = if isFloatType rep then MO_F_Ne else MO_Ne - cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] - if_stmt = CmmCondBranch cond deflt_blk_id - return (consCgStmt if_stmt blk) - -mk_lit_switch scrut deflt_blk_id branches - = do { dflags <- getDynFlags - ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches - ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches - ; lo_blk_id <- forkCgStmts lo_blk - ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id - ; return (if_stmt `consCgStmt` hi_blk) } - where - n_branches = length branches - (mid_lit,_) = branches !! (n_branches `div` 2) - -- See notes above re mid_tag - - (lo_branches, hi_branches) = span is_lo branches - is_lo (t,_) = t < mid_lit - - cond dflags = CmmMachOp (mkLtOp dflags mid_lit) - [scrut, CmmLit (mkSimpleLit dflags mid_lit)] - -------------------------------------------------------------------------- --- --- Simultaneous assignment --- -------------------------------------------------------------------------- - - -emitSimultaneously :: CmmStmts -> Code --- Emit code to perform the assignments in the --- input simultaneously, using temporary variables when necessary. --- --- The Stmts must be: --- CmmNop, CmmComment, CmmAssign, CmmStore --- and nothing else - - --- We use the strongly-connected component algorithm, in which --- * the vertices are the statements --- * an edge goes from s1 to s2 iff --- s1 assigns to something s2 uses --- that is, if s1 should *follow* s2 in the final order - -type CVertex = (Int, CmmStmt) -- Give each vertex a unique number, - -- for fast comparison - -emitSimultaneously stmts - = codeOnly $ - case filterOut isNopStmt (stmtList stmts) of - -- Remove no-ops - [] -> nopC - [stmt] -> stmtC stmt -- It's often just one stmt - stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list) - -doSimultaneously1 :: [CVertex] -> Code -doSimultaneously1 vertices = do - dflags <- getDynFlags - let - edges = [ (vertex, key1, edges_from stmt1) - | vertex@(key1, stmt1) <- vertices - ] - edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - mustFollow dflags stmt1 stmt2 - ] - components = stronglyConnCompFromEdgedVertices edges - - -- do_components deal with one strongly-connected component - -- Not cyclic, or singleton? Just do it - do_component (AcyclicSCC (_n, stmt)) = stmtC stmt - do_component (CyclicSCC []) - = panic "doSimultaneously1: do_component (CyclicSCC [])" - do_component (CyclicSCC [(_n, stmt)]) = stmtC stmt - - -- Cyclic? Then go via temporaries. Pick one to - -- break the loop and try again with the rest. - do_component (CyclicSCC ((_n, first_stmt) : rest)) - = do { from_temp <- go_via_temp first_stmt - ; doSimultaneously1 rest - ; stmtC from_temp } - - go_via_temp (CmmAssign dest src) - = do { dflags <- getDynFlags - ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong - ; stmtC (CmmAssign (CmmLocal tmp) src) - ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } - go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong - ; stmtC (CmmAssign (CmmLocal tmp) src) - ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } - go_via_temp _ = panic "doSimultaneously1: go_via_temp" - mapCs do_component components - -mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool -mustFollow dflags x y = x `mustFollow'` y - where CmmAssign reg _ `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt - CmmStore loc e `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt - CmmNop `mustFollow'` _ = False - CmmComment _ `mustFollow'` _ = False - _ `mustFollow'` _ = panic "mustFollow" - - -anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool --- True if the fn is true of any input of the stmt -anySrc p (CmmAssign _ e) = p e -anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side -anySrc _ (CmmComment _) = False -anySrc _ CmmNop = False -anySrc _ _ = True -- Conservative - -locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool --- (locUsedIn a r e) checks whether writing to r[a] could affect the value of --- 'e'. Returns True if it's not sure. -locUsedIn _ _ (CmmLit _) = False -locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep -locUsedIn _ _ (CmmReg _) = False -locUsedIn _ _ (CmmRegOff _ _) = False -locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es -locUsedIn _ _ (CmmStackSlot _ _) = panic "locUsedIn: CmmStackSlot" - -possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool --- Assumes that distinct registers (eg Hp, Sp) do not --- point to the same location, nor any offset thereof. -possiblySameLoc (CmmReg r1) _ (CmmReg r2) _ = r1 == r2 -possiblySameLoc (CmmReg r1) _ (CmmRegOff r2 0) _ = r1 == r2 -possiblySameLoc (CmmRegOff r1 0) _ (CmmReg r2) _ = r1 == r2 -possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 - = r1==r2 && end1 > start2 && end2 > start1 - where - end1 = start1 + widthInBytes (typeWidth rep1) - end2 = start2 + widthInBytes (typeWidth rep2) - -possiblySameLoc _ _ (CmmLit _) _ = False -possiblySameLoc _ _ _ _ = True -- Conservative - -------------------------------------------------------------------------- --- --- Static Reference Tables --- -------------------------------------------------------------------------- - --- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to --- the nested bindings via the monad. - -getSRTInfo :: FCode C_SRT -getSRTInfo = do - dflags <- getDynFlags - srt_lbl <- getSRTLabel - srt <- getSRT - case srt of - -- TODO: Should we panic in this case? - -- Someone obviously thinks there should be an SRT - NoSRT -> return NoC_SRT - SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?" - SRT off len bmp - | len > hALF_WORD_SIZE_IN_BITS dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))] - -> do id <- newUnique - let srt_desc_lbl = mkLargeSRTLabel id - emitRODataLits "getSRTInfo" srt_desc_lbl - ( cmmLabelOffW dflags srt_lbl off - : mkWordCLit dflags (toInteger len) - : map (mkWordCLit dflags . fromStgWord) bmp) - return (C_SRT srt_desc_lbl 0 (srt_escape dflags)) - - | otherwise - -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp)))) - -- The fromIntegral converts to StgHalfWord - -srt_escape :: DynFlags -> StgHalfWord -srt_escape dflags = toStgHalfWord dflags (-1) - -- ----------------------------------------------------------------------------- -- -- STG/Cmm GlobalReg diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs deleted file mode 100644 index 7371ca56a2..0000000000 --- a/compiler/codeGen/ClosureInfo.lhs +++ /dev/null @@ -1,1122 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The Univserity of Glasgow 1992-2004 -% - - Data structures which describe closures, and - operations over those data structures - - Nothing monadic in here - -Much of the rationale for these things is in the ``details'' part of -the STG paper. - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module ClosureInfo ( - idRepArity, - - ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but - StandardFormInfo(..), -- mkCmmInfo looks inside - SMRep, - - ArgDescr(..), Liveness, - C_SRT(..), needsSRT, - - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, - - mkClosureInfo, mkConInfo, maybeIsLFCon, - closureSize, - - ConTagZ, dataConTagZ, - - infoTableLabelFromCI, entryLabelFromCI, - closureLabelFromCI, - isLFThunk, closureUpdReqd, - closureNeedsUpdSpace, closureIsThunk, - closureSingleEntry, closureReEntrant, isConstrClosure_maybe, - closureFunInfo, isKnownFun, - funTag, funTagLFInfo, tagForArity, clHasCafRefs, - - enterIdLabel, enterReturnPtLabel, - - nodeMustPointToIt, - CallMethod(..), getCallMethod, - - blackHoleOnEntry, - - staticClosureRequired, - - isToplevClosure, - closureValDescr, closureTypeDescr, -- profiling - - isStaticClosure, - cafBlackHoleClosureInfo, - - staticClosureNeedsLink, - - -- CgRep and its functions - CgRep(..), nonVoidArg, - argMachRep, primRepToCgRep, - isFollowableArg, isVoidArg, - isFloatingArg, is64BitArg, - separateByPtrFollowness, - cgRepSizeW, cgRepSizeB, - retAddrSizeW, - typeCgRep, idCgRep, tyConCgRep, - - ) where - -#include "../includes/MachDeps.h" -#include "HsVersions.h" - -import StgSyn -import SMRep - -import CLabel -import Cmm -import Unique -import Var -import Id -import IdInfo -import DataCon -import Name -import Type -import TypeRep -import TcType -import TyCon -import BasicTypes -import Outputable -import FastString -import Constants -import DynFlags -import Util -\end{code} - - -%************************************************************************ -%* * -\subsection[ClosureInfo-datatypes]{Data types for closure information} -%* * -%************************************************************************ - -Information about a closure, from the code generator's point of view. - -A ClosureInfo decribes the info pointer of a closure. It has -enough information - a) to construct the info table itself - b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) - -We make a ClosureInfo for - - each let binding (both top level and not) - - each data constructor (for its shared static and - dynamic info tables) - -\begin{code} -data ClosureInfo - = ClosureInfo { - closureName :: !Name, -- The thing bound to this closure - closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below) - closureSMRep :: !SMRep, -- representation used by storage mgr - closureSRT :: !C_SRT, -- What SRT applies to this closure - closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String, -- closure description (for profiling) - closureInfLcl :: Bool -- can the info pointer be a local symbol? - } - - -- Constructor closures don't have a unique info table label (they use - -- the constructor's info table), and they don't have an SRT. - | ConInfo { - closureCon :: !DataCon, - closureSMRep :: !SMRep - } -\end{code} - -%************************************************************************ -%* * -\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info} -%* * -%************************************************************************ - -Information about an identifier, from the code generator's point of -view. Every identifier is bound to a LambdaFormInfo in the -environment, which gives the code generator enough info to be able to -tail call or return that identifier. - -Note that a closure is usually bound to an identifier, so a -ClosureInfo contains a LambdaFormInfo. - -\begin{code} -data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should reall be in ClosureInfo) - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. Treat like - -- updatable "LFThunk"... - -- Imported things which we do know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - - | LFLetNoEscape -- See LetNoEscape module for precise description of - -- these "lets". - !RepArity -- arity; - - | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to - -- be in the heap, so we make a black hole to hold it. - - - -------------------------- --- StandardFormInfo tells whether this thunk has one of --- a small number of standard forms - -data StandardFormInfo - = NonStandardThunk - -- Not of of the standard forms - - | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n -\end{code} - - -%************************************************************************ -%* * - CgRep -%* * -%************************************************************************ - -An CgRep is an abstraction of a Type which tells the code generator -all it needs to know about the calling convention for arguments (and -results) of that type. In particular, the ArgReps of a function's -arguments are used to decide which of the RTS's generic apply -functions to call when applying an unknown function. - -It contains more information than the back-end data type MachRep, -so one can easily convert from CgRep -> MachRep. (Except that -there's no MachRep for a VoidRep.) - -It distinguishes - pointers from non-pointers (we sort the pointers together - when building closures) - - void from other types: a void argument is different from no argument - -All 64-bit types map to the same CgRep, because they're passed in the -same register, but a PtrArg is still different from an NonPtrArg -because the function's entry convention has to take into account the -pointer-hood of arguments for the purposes of describing the stack on -entry to the garbage collector. - -\begin{code} -data CgRep - = VoidArg -- Void - | PtrArg -- Word-sized heap pointer, followed - -- by the garbage collector - | NonPtrArg -- Word-sized non-pointer - -- (including addresses not followed by GC) - | LongArg -- 64-bit non-pointer - | FloatArg -- 32-bit float - | DoubleArg -- 64-bit float - deriving Eq - -instance Outputable CgRep where - ppr VoidArg = ptext (sLit "V_") - ppr PtrArg = ptext (sLit "P_") - ppr NonPtrArg = ptext (sLit "I_") - ppr LongArg = ptext (sLit "L_") - ppr FloatArg = ptext (sLit "F_") - ppr DoubleArg = ptext (sLit "D_") - -argMachRep :: DynFlags -> CgRep -> CmmType -argMachRep dflags PtrArg = gcWord dflags -argMachRep dflags NonPtrArg = bWord dflags -argMachRep _ LongArg = b64 -argMachRep _ FloatArg = f32 -argMachRep _ DoubleArg = f64 -argMachRep _ VoidArg = panic "argMachRep:VoidRep" - -primRepToCgRep :: PrimRep -> CgRep -primRepToCgRep VoidRep = VoidArg -primRepToCgRep PtrRep = PtrArg -primRepToCgRep IntRep = NonPtrArg -primRepToCgRep WordRep = NonPtrArg -primRepToCgRep Int64Rep = LongArg -primRepToCgRep Word64Rep = LongArg -primRepToCgRep AddrRep = NonPtrArg -primRepToCgRep FloatRep = FloatArg -primRepToCgRep DoubleRep = DoubleArg - -idCgRep :: Id -> CgRep -idCgRep x = typeCgRep . idType $ x - -tyConCgRep :: TyCon -> CgRep -tyConCgRep = primRepToCgRep . tyConPrimRep - -typeCgRep :: UnaryType -> CgRep -typeCgRep = primRepToCgRep . typePrimRep -\end{code} - -Whether or not the thing is a pointer that the garbage-collector -should follow. Or, to put it another (less confusing) way, whether -the object in question is a heap object. - -Depending on the outcome, this predicate determines what stack -the pointer/object possibly will have to be saved onto, and the -computation of GC liveness info. - -\begin{code} -isFollowableArg :: CgRep -> Bool -- True <=> points to a heap object -isFollowableArg PtrArg = True -isFollowableArg _ = False - -isVoidArg :: CgRep -> Bool -isVoidArg VoidArg = True -isVoidArg _ = False - -nonVoidArg :: CgRep -> Bool -nonVoidArg VoidArg = False -nonVoidArg _ = True - --- isFloatingArg is used to distinguish @Double@ and @Float@ which --- cause inadvertent numeric conversions if you aren't jolly careful. --- See codeGen/CgCon:cgTopRhsCon. - -isFloatingArg :: CgRep -> Bool -isFloatingArg DoubleArg = True -isFloatingArg FloatArg = True -isFloatingArg _ = False - -is64BitArg :: CgRep -> Bool -is64BitArg LongArg = True -is64BitArg _ = False -\end{code} - -\begin{code} -separateByPtrFollowness :: [(CgRep,a)] -> ([(CgRep,a)], [(CgRep,a)]) --- Returns (ptrs, non-ptrs) -separateByPtrFollowness things - = sep_things things [] [] - -- accumulating params for follow-able and don't-follow things... - where - sep_things [] bs us = (reverse bs, reverse us) - sep_things ((PtrArg,a):ts) bs us = sep_things ts ((PtrArg,a):bs) us - sep_things (t :ts) bs us = sep_things ts bs (t:us) -\end{code} - -\begin{code} -cgRepSizeB :: DynFlags -> CgRep -> ByteOff -cgRepSizeB dflags DoubleArg = dOUBLE_SIZE dflags -cgRepSizeB _ LongArg = wORD64_SIZE -cgRepSizeB _ VoidArg = 0 -cgRepSizeB dflags _ = wORD_SIZE dflags - -cgRepSizeW :: DynFlags -> CgRep -> ByteOff -cgRepSizeW dflags DoubleArg = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags -cgRepSizeW _ VoidArg = 0 -cgRepSizeW _ _ = 1 - -retAddrSizeW :: WordOff -retAddrSizeW = 1 -- One word -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-construction]{Functions which build LFInfos} -%* * -%************************************************************************ - -\begin{code} -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo - -mkLFReEntrant top fvs args arg_descr - = LFReEntrant top (length args) (null fvs) arg_descr - -mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo -mkLFThunk thunk_ty top fvs upd_flag - = ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) - -might_be_a_function :: Type -> Bool --- Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as poss -might_be_a_function ty - | UnaryRep rep <- repType ty - , Just tc <- tyConAppTyCon_maybe rep - , isDataTyCon tc - = False - | otherwise - = True -\end{code} - -@mkConLFInfo@ is similar, for constructors. - -\begin{code} -mkConLFInfo :: DataCon -> LambdaFormInfo -mkConLFInfo con = LFCon con - -maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon -maybeIsLFCon (LFCon con) = Just con -maybeIsLFCon _ = Nothing - -mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo -mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) - -mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo -mkApLFInfo id upd_flag arity - = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) -\end{code} - -Miscellaneous LF-infos. - -\begin{code} -mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id = LFUnknown (might_be_a_function (idType id)) - -mkLFLetNoEscape :: RepArity -> LambdaFormInfo -mkLFLetNoEscape = LFLetNoEscape - -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - = case idRepArity id of - n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 - _ -> mkLFArgument id -- Not sure of exact arity -\end{code} - -\begin{code} -isLFThunk :: LambdaFormInfo -> Bool -isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk LFBlackHole = True - -- return True for a blackhole: this function is used to determine - -- whether to use the thunk header in SMP mode, and a blackhole - -- must have one. -isLFThunk _ = False -\end{code} - -\begin{code} --- We keep the *zero-indexed* tag in the srt_len field of the info --- table of a data constructor. -type ConTagZ = Int -- A *zero-indexed* contructor tag - -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG -\end{code} - - -%************************************************************************ -%* * - Building ClosureInfos -%* * -%************************************************************************ - -\begin{code} -mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words - -> C_SRT - -> String -- String descriptor - -> ClosureInfo -mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr - = ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSMRep = sm_rep, - closureSRT = srt_info, - closureType = idType id, - closureDescr = descr, - closureInfLcl = isDataConWorkId id } - -- Make the _info pointer for the implicit datacon worker binding - -- local. The reason we can do this is that importing code always - -- either uses the _closure or _con_info. By the invariants in CorePrep - -- anything else gets eta expanded. - where - name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - nonptr_wds = tot_wds - ptr_wds - -mkConInfo :: DynFlags - -> Bool -- Is static - -> DataCon - -> Int -> Int -- Total and pointer words - -> ClosureInfo -mkConInfo dflags is_static data_con tot_wds ptr_wds - = ConInfo { closureSMRep = sm_rep, - closureCon = data_con } - where - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - lf_info = mkConLFInfo data_con - nonptr_wds = tot_wds - ptr_wds -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} -%* * -%************************************************************************ - -\begin{code} -closureSize :: DynFlags -> ClosureInfo -> WordOff -closureSize dflags cl_info = heapClosureSize dflags (closureSMRep cl_info) -\end{code} - -\begin{code} --- we leave space for an update if either (a) the closure is updatable --- or (b) it is a static thunk. This is because a static thunk needs --- a static link field in a predictable place (after the slop), regardless --- of whether it is updatable or not. -closureNeedsUpdSpace :: ClosureInfo -> Bool -closureNeedsUpdSpace (ClosureInfo { closureLFInfo = - LFThunk TopLevel _ _ _ _ }) = True -closureNeedsUpdSpace cl_info = closureUpdReqd cl_info -\end{code} - -%************************************************************************ -%* * -\subsection[SMreps]{Choosing SM reps} -%* * -%************************************************************************ - -\begin{code} -lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" - -thunkClosureType :: StandardFormInfo -> ClosureTypeInfo -thunkClosureType (SelectorThunk off) = ThunkSelector off -thunkClosureType _ = Thunk - --- We *do* get non-updatable top-level thunks sometimes. eg. f = g --- gets compiled to a jump to g (if g has non-zero arity), instead of --- messing around with update frames and PAPs. We set the closure type --- to FUN_STATIC in this case. -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@} -%* * -%************************************************************************ - -Be sure to see the stg-details notes about these... - -\begin{code} -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) - = not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top - -- If it is not top level we will point to it - -- We can have a \r closure with no_fvs which - -- is not top level as special case cgRhsClosure - -- has been dissabled in favour of let floating - - -- For lex_profiling we also access the cost centre for a - -- non-inherited function i.e. not top level - -- the not top case above ensures this is ok. - -nodeMustPointToIt _ (LFCon _) = True - - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. - -nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) - -nodeMustPointToIt _ (LFThunk _ _ _ _ _) - = True -- Node must point to any standard-form thunk - -nodeMustPointToIt _ (LFUnknown _) = True -nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt _ (LFLetNoEscape _) = False -\end{code} - -The entry conventions depend on the type of closure being entered, -whether or not it has free variables, and whether we're running -sequentially or in parallel. - -\begin{tabular}{lllll} -Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\ -Unknown & no & yes & stack & node \\ -Known fun ($\ge$ 1 arg), no fvs & no & no & registers & fast entry (enough args) \\ -\ & \ & \ & \ & slow entry (otherwise) \\ -Known fun ($\ge$ 1 arg), fvs & no & yes & registers & fast entry (enough args) \\ -0 arg, no fvs @\r,\s@ & no & no & n/a & direct entry \\ -0 arg, no fvs @\u@ & no & yes & n/a & node \\ -0 arg, fvs @\r,\s@ & no & yes & n/a & direct entry \\ -0 arg, fvs @\u@ & no & yes & n/a & node \\ - -Unknown & yes & yes & stack & node \\ -Known fun ($\ge$ 1 arg), no fvs & yes & no & registers & fast entry (enough args) \\ -\ & \ & \ & \ & slow entry (otherwise) \\ -Known fun ($\ge$ 1 arg), fvs & yes & yes & registers & node \\ -0 arg, no fvs @\r,\s@ & yes & no & n/a & direct entry \\ -0 arg, no fvs @\u@ & yes & yes & n/a & node \\ -0 arg, fvs @\r,\s@ & yes & yes & n/a & node \\ -0 arg, fvs @\u@ & yes & yes & n/a & node\\ -\end{tabular} - -When black-holing, single-entry closures could also be entered via node -(rather than directly) to catch double-entry. - -\begin{code} -data CallMethod - = EnterIt -- no args, not a function - - | JumpToIt CLabel -- no args, not a function, but we - -- know what its entry code is - - | ReturnIt -- it's a function, but we have - -- zero args to apply to it, so just - -- return it. - - | ReturnCon DataCon -- It's a data constructor, just return it - - | SlowCall -- Unknown fun, or known fun with - -- too few args. - - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity - -getCallMethod :: DynFlags - -> Name -- Function being applied - -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> CallMethod - -getCallMethod dflags _ _ lf_info _ - | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. - -- The reason is that the closure may have been - -- fetched since we allocated it. - EnterIt - -getCallMethod dflags name caf (LFReEntrant _ arity _ _) n_args - | n_args == 0 = ASSERT( arity /= 0 ) - ReturnIt -- No args at all - | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name caf) arity - -getCallMethod dflags _ _ (LFCon con) n_args - -- when profiling, we must always enter a closure when we use it, so - -- that the closure can be recorded as used for LDV profiling. - | gopt Opt_SccProfilingOn dflags - = EnterIt - | otherwise - = ASSERT( n_args == 0 ) - ReturnCon con - -getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) _n_args - | is_fun -- it *might* be a function, so we must "call" it (which is - -- always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] - - -- Since is_fun is False, we are *definitely* looking at a data value - | otherwise - = EnterIt - -- We used to have ASSERT( n_args == 0 ), but actually it is - -- possible for the optimiser to generate - -- let bot :: Int = error Int "urk" - -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 - -- This happens as a result of the case-of-error transformation - -- So the right thing to do is just to enter the thing - --- Old version: --- | updatable || gopt Opt_Ticky dflags -- to catch double entry --- = EnterIt --- | otherwise -- Jump direct to code for single-entry thunks --- = JumpToIt (thunkEntryLabel name caf std_form_info updatable) --- --- Now we never use JumpToIt, even if the thunk is single-entry, since --- the thunk may have already been entered and blackholed by another --- processor. - - -getCallMethod _ _ _ (LFUnknown True) _ - = SlowCall -- Might be a function - -getCallMethod _ name _ (LFUnknown False) n_args - | n_args > 0 - = WARN( True, ppr name <+> ppr n_args ) - SlowCall -- Note [Unsafe coerce complications] - - | otherwise - = EnterIt -- Not a function - -getCallMethod _ _ _ LFBlackHole _ - = SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it - -getCallMethod dflags name _ (LFLetNoEscape 0) _ - = JumpToIt (enterReturnPtLabel dflags (nameUnique name)) - -getCallMethod dflags name _ (LFLetNoEscape arity) n_args - | n_args == arity = DirectEntry (enterReturnPtLabel dflags (nameUnique name)) arity - | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) - - -blackHoleOnEntry :: ClosureInfo -> Bool -blackHoleOnEntry ConInfo{} = False -blackHoleOnEntry cl_info - | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure - - | otherwise - = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False - LFLetNoEscape _ -> False - LFThunk _ _no_fvs _updatable _ _ -> True - _other -> panic "blackHoleOnEntry" -- Should never happen - -isKnownFun :: LambdaFormInfo -> Bool -isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun (LFLetNoEscape _) = True -isKnownFun _ = False -\end{code} - -Note [Unsafe coerce complications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some (badly-optimised) DPH code we see this - Module X: rr :: Int = error Int "Urk" - Module Y: ...((X.rr |> g) True) ... - where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say - -It's badly optimised, because knowing that 'X.rr' is bottom, we should -have dumped the application to True. But it should still work. These -strange unsafe coercions arise from the case-of-error transformation: - (case (error Int "foo") of { ... }) True ----> (error Int "foo" |> g) True - -Anyway, the net effect is that in STG-land, when casts are discarded, -we *can* see a value of type Int applied to an argument. This only happens -if (a) the programmer made a mistake, or (b) the value of type Int is -actually bottom. - -So it's wrong to trigger an ASSERT failure in this circumstance. Instead -we now emit a WARN -- mainly to draw attention to a probably-badly-optimised -program fragment -- and do the conservative thing which is SlowCall. - - ------------------------------------------------------------------------------ -SRT-related stuff - -\begin{code} -staticClosureNeedsLink :: ClosureInfo -> Bool --- A static closure needs a link field to aid the GC when traversing --- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields --- In case (b), the constructor's fields themselves play the role --- of the SRT. -staticClosureNeedsLink (ClosureInfo { closureSRT = srt }) - = needsSRT srt -staticClosureNeedsLink (ConInfo { closureSMRep = rep }) - = not (isStaticNoCafCon rep) -\end{code} - -Note [Entering error thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - fail :: Int - fail = error Int "Urk" - - foo :: Bool -> Bool - foo True y = (fail `cast` Bool -> Bool) y - foo False y = False - -This looks silly, but it can arise from case-of-error. Even if it -does, we'd usually see that 'fail' is a bottoming function and would -discard the extra argument 'y'. But even if that does not occur, -this program is still OK. We will enter 'fail', which never returns. - -The WARN is just to alert me to the fact that we aren't spotting that -'fail' is bottoming. - -(We are careful never to make a funtion value look like a data type, -because we can't enter a function closure -- but that is not the -problem here.) - - -Avoiding generating entries and info tables -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, for every function we generate all of the following, -just in case. But they aren't always all needed, as noted below: - -[NB1: all of this applies only to *functions*. Thunks always -have closure, info table, and entry code.] - -[NB2: All are needed if the function is *exported*, just to play safe.] - - -* Fast-entry code ALWAYS NEEDED - -* Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] - -* The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) - - Why case (a) here? Because if the arg-satis check fails, - UpdatePAP stuffs a pointer to the function closure in the PAP. - [Could be changed; UpdatePAP could stuff in a code ptr instead, - but doesn't seem worth it.] - - [NB: these conditions imply that we might need the closure - without the slow-entry code. Here's how. - - f x y = let g w = ...x..y..w... - in - ...(g t)... - - Here we need a closure for g which contains x and y, - but since the calls are all saturated we just jump to the - fast entry point for g, with R1 pointing to the closure for g.] - - -* Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. - -\begin{code} -staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool -staticClosureRequired _ bndr_info - (LFReEntrant top_level _ _ _) -- It's a function - = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) - -staticClosureRequired _ _ _ = True -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.} -%* * -%************************************************************************ - -\begin{code} -isStaticClosure :: ClosureInfo -> Bool -isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) - -closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info -closureUpdReqd ConInfo{} = False - -lfUpdatable :: LambdaFormInfo -> Bool -lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable LFBlackHole = True - -- Black-hole closures are allocated to receive the results of an - -- alg case with a named default... so they need to be updated. -lfUpdatable _ = False - -closureIsThunk :: ClosureInfo -> Bool -closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info -closureIsThunk ConInfo{} = False - -closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry _ = False - -closureReEntrant :: ClosureInfo -> Bool -closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True -closureReEntrant _ = False - -isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon -isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con -isConstrClosure_maybe _ = Nothing - -closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) -closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info -closureFunInfo _ = Nothing - -lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing - -funTag :: DynFlags -> ClosureInfo -> Int -funTag dflags (ClosureInfo { closureLFInfo = lf_info }) - = funTagLFInfo dflags lf_info -funTag _ _ = 0 - --- maybe this should do constructor tags too? -funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int -funTagLFInfo dflags lf - -- A function is tagged with its arity - | Just (arity,_) <- lfFunInfo lf, - Just tag <- tagForArity dflags arity - = tag - - -- other closures (and unknown ones) are not tagged - | otherwise - = 0 - -tagForArity :: DynFlags -> RepArity -> Maybe Int -tagForArity dflags i - | i <= mAX_PTR_TAG dflags = Just i - | otherwise = Nothing - -clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs -clHasCafRefs (ConInfo {}) = NoCafRefs -\end{code} - -\begin{code} -isToplevClosure :: ClosureInfo -> Bool -isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) - = case lf_info of - LFReEntrant TopLevel _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _ -> False -isToplevClosure _ = False -\end{code} - -Label generation. - -\begin{code} -infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI = fst . labelsFromCI - -entryLabelFromCI :: DynFlags -> ClosureInfo -> CLabel -entryLabelFromCI dflags ci - | tablesNextToCode dflags = info_lbl - | otherwise = entry_lbl - where (info_lbl, entry_lbl) = labelsFromCI ci - -labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) -labelsFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfLcl = is_lcl }) - = case lf_info of - LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) - - LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset - - LFThunk _ _ upd_flag (ApThunk arity) _ -> - bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - - LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - - LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - - _ -> panic "labelsFromCI" - where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) - -labelsFromCI cl@(ConInfo { closureCon = con, - closureSMRep = rep }) - | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl - | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl - where - name = dataConName con - -bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) -bothL (f, g) x y = (f x y, g x y) - --- ClosureInfo for a closure (as opposed to a constructor) is always local -closureLabelFromCI :: ClosureInfo -> CLabel -closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm $ clHasCafRefs cl -closureLabelFromCI _ = panic "closureLabelFromCI" - --- thunkEntryLabel is a local help function, not exported. It's used from both --- entryLabelFromCI and getCallMethod. - -{- UNUSED: -thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel -thunkEntryLabel _thunk_id _ (ApThunk arity) is_updatable - = enterApLabel is_updatable arity -thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel upd_flag offset -thunkEntryLabel thunk_id caf _ _is_updatable - = enterIdLabel thunk_id caf --} - -{- UNUSED: -enterApLabel :: Bool -> Int -> CLabel -enterApLabel is_updatable arity - | tablesNextToCode = mkApInfoTableLabel is_updatable arity - | otherwise = mkApEntryLabel is_updatable arity --} - -{- UNUSED: -enterSelectorLabel :: Bool -> Int -> CLabel -enterSelectorLabel upd_flag offset - | tablesNextToCode = mkSelectorInfoLabel upd_flag offset - | otherwise = mkSelectorEntryLabel upd_flag offset --} - -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel -enterIdLabel dflags id - | tablesNextToCode dflags = mkInfoTableLabel id - | otherwise = mkEntryLabel id - -enterReturnPtLabel :: DynFlags -> Unique -> CLabel -enterReturnPtLabel dflags name - | tablesNextToCode dflags = mkReturnInfoLabel name - | otherwise = mkReturnPtLabel name -\end{code} - - -We need a black-hole closure info to pass to @allocDynClosure@ when we -want to allocate the black hole on entry to a CAF. These are the only -ways to build an LFBlackHole, maintaining the invariant that it really -is a black hole and not something else. - -\begin{code} -cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo -cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) - = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole, - closureSMRep = blackHoleRep, - closureSRT = NoC_SRT, - closureType = ty, - closureDescr = "", - closureInfLcl = False } -cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.} -%* * -%************************************************************************ - -Profiling requires two pieces of information to be determined for -each closure's info table --- description and type. - -The description is stored directly in the @CClosureInfoTable@ when the -info table is built. - -The type is determined from the type information stored with the @Id@ -in the closure info using @closureTypeDescr@. - -\begin{code} -closureValDescr, closureTypeDescr :: ClosureInfo -> String -closureValDescr (ClosureInfo {closureDescr = descr}) - = descr -closureValDescr (ConInfo {closureCon = con}) - = occNameString (getOccName con) - -closureTypeDescr (ClosureInfo { closureType = ty }) - = getTyDescription ty -closureTypeDescr (ConInfo { closureCon = data_con }) - = occNameString (getOccName (dataConTyCon data_con)) - -getTyDescription :: Type -> String -getTyDescription ty - = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> - case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon - ForAllTy _ ty -> getTyDescription ty - LitTy n -> getTyLitDescription n - } - where - fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other - - -getTyLitDescription :: TyLit -> String -getTyLitDescription l = - case l of - NumTyLit n -> show n - StrTyLit n -> show n -\end{code} diff --git a/compiler/codeGen/ClosureInfo.lhs-boot b/compiler/codeGen/ClosureInfo.lhs-boot deleted file mode 100644 index b069905d3e..0000000000 --- a/compiler/codeGen/ClosureInfo.lhs-boot +++ /dev/null @@ -1,6 +0,0 @@ -\begin{code} -module ClosureInfo where - -data LambdaFormInfo -data ClosureInfo -\end{code}
\ No newline at end of file diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index fe00d7c384..91b0c8ba04 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -96,7 +96,7 @@ reschedule liveness node_reqd = panic "granReschedule" -- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -- this kind of macro at the beginning of the following kinds of basic bocks: -- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- \item Slow entry code where node is not alive (see @StgCmmClosure.lhs@). Normally -- we use @fetchAndReschedule@ at a slow entry code. -- \item Fast entry code (see @CgClosure.lhs@). -- \item Alternatives in case expressions (@CLabelledCode@ structures), provided diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 87793ab20f..39676635aa 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -30,7 +30,9 @@ module StgCmmLayout ( cmmGetClosureType, infoTable, infoTableClosureType, infoTablePtrs, infoTableNonPtrs, - funInfoTable + funInfoTable, + + ArgRep(..), toArgRep, argRepSizeW ) where @@ -329,15 +331,15 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- Classifying arguments: ArgRep ------------------------------------------------------------------------- --- ArgRep is not exported (even abstractly) --- It's a local helper type for classification +-- ArgRep is exported, but only for use in the byte-code generator which +-- also needs to know about the classification of arguments. -data ArgRep = P -- GC Ptr - | N -- One-word non-ptr - | L -- Two-word non-ptr (long) - | V -- Void - | F -- Float - | D -- Double +data ArgRep = P -- GC Ptr + | N -- Word-sized non-ptr + | L -- 64-bit non-ptr (long) + | V -- Void + | F -- Float + | D -- Double instance Outputable ArgRep where ppr P = text "P" ppr N = text "N" |