diff options
Diffstat (limited to 'compiler/codeGen/CgBindery.lhs')
| -rw-r--r-- | compiler/codeGen/CgBindery.lhs | 564 |
1 files changed, 0 insertions, 564 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} - |