diff options
Diffstat (limited to 'compiler/codeGen/CgBindery.lhs')
| -rw-r--r-- | compiler/codeGen/CgBindery.lhs | 387 |
1 files changed, 185 insertions, 202 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 65f8a52981..198e192f5c 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -5,37 +5,31 @@ \section[CgBindery]{Utility functions related to doing @CgBindings@} \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 CgBindery ( - CgBindings, CgIdInfo, - StableLoc, VolatileLoc, + CgBindings, CgIdInfo, + StableLoc, VolatileLoc, - cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, + cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - stableIdInfo, heapIdInfo, + stableIdInfo, heapIdInfo, taggedStableIdInfo, taggedHeapIdInfo, - letNoEscapeIdInfo, idInfoToAmode, + letNoEscapeIdInfo, idInfoToAmode, - addBindC, addBindsC, + addBindC, addBindsC, - nukeVolatileBinds, - nukeDeadBindings, - getLiveStackSlots, + nukeVolatileBinds, + nukeDeadBindings, + getLiveStackSlots, getLiveStackBindings, - bindArgsToStack, rebindToStack, - bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, - getArgAmode, getArgAmodes, - getCgIdInfo, - getCAddrModeIfVolatile, getVolatileRegs, - maybeLetNoEscape, + bindArgsToStack, rebindToStack, + bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, + bindNewToTemp, + getArgAmode, getArgAmodes, + getCgIdInfo, + getCAddrModeIfVolatile, getVolatileRegs, + maybeLetNoEscape, ) where import CgMonad @@ -47,7 +41,7 @@ import ClosureInfo import Constants import OldCmm -import PprCmm ( {- instance Outputable -} ) +import PprCmm ( {- instance Outputable -} ) import SMRep import Id import DataCon @@ -64,40 +58,39 @@ 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 +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. +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 + = 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 :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo mkCgIdInfo id vol stb lf = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } where tag | Just con <- isDataConWorkId_maybe id, @@ -114,16 +107,16 @@ mkCgIdInfo id vol stb 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 + , 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 +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). + | 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. @@ -131,7 +124,7 @@ mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon -> CgIdInfo mkTaggedCgIdInfo 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 con } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -141,20 +134,18 @@ the @CgBindings@ environment in @CgBindery@. data StableLoc = NoStableLoc - | VirStkLoc VirtualSpOffset -- The thing is held in this - -- stack slot + | 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) + | 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 -\end{code} + | 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 -\begin{code} instance PlatformOutputable CgIdInfo where pprPlatform platform (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info @@ -175,9 +166,9 @@ instance PlatformOutputable StableLoc where \end{code} %************************************************************************ -%* * +%* * \subsection[Bindery-idInfo]{Manipulating IdInfo} -%* * +%* * %************************************************************************ \begin{code} @@ -191,7 +182,7 @@ letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info @@ -216,7 +207,7 @@ untagNodeIdInfo id offset lf_info tag idInfoToAmode :: CgIdInfo -> FCode CmmExpr idInfoToAmode info = case cg_vol info of { - RegLoc reg -> returnFC (CmmReg reg) ; + RegLoc reg -> returnFC (CmmReg reg) ; VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off) mach_rep) ; VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off @@ -226,14 +217,14 @@ idInfoToAmode info 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) } + ; 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 + -- 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)) } @@ -256,16 +247,16 @@ cgIdInfoArgRep = cg_rep maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off -maybeLetNoEscape _ = Nothing +maybeLetNoEscape _ = Nothing \end{code} %************************************************************************ -%* * +%* * \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} -%* * +%* * %************************************************************************ -.There are three basic routines, for adding (@addBindC@), modifying +There are three basic routines, for adding (@addBindC@), modifying (@modifyBindC@) and looking up (@getCgIdInfo@) bindings. A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. @@ -274,72 +265,72 @@ 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 + 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 + 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 + binds <- getBinds + setBinds $ modifyVarEnv mangle_fn binds name getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- 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 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 - }}}} + = do { -- 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 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 + = 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 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 @@ -357,71 +348,68 @@ nukeVolatileBinds binds %************************************************************************ -%* * +%* * \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 } + = 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 +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 } + 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 - } + { 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 } -\end{code} -\begin{code} getArgAmode :: StgArg -> FCode (CgRep, CmmExpr) getArgAmode (StgVarArg var) - = do { info <- getCgIdInfo var - ; amode <- idInfoToAmode info - ; return (cgIdInfoArgRep info, amode ) } + = 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) } + = do { cmm_lit <- cgLit lit + ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" @@ -429,15 +417,15 @@ getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) | isStgTypeArg atom = getArgAmodes atoms - | otherwise = do { amode <- getArgAmode atom - ; amodes <- getArgAmodes atoms - ; return ( amode : amodes ) } + | otherwise = 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} @@ -466,22 +454,20 @@ bindNewToUntagNode id offset lf_info tag -- temporary. bindNewToTemp :: Id -> FCode LocalReg bindNewToTemp id - = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) - return temp_reg + = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) + return temp_reg where uniq = getUnique id temp_reg = LocalReg uniq (argMachRep (idCgRep id)) - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code bindNewToReg name reg lf_info = addBindC name info where info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info -\end{code} -\begin{code} rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset = modifyBindC name replace_stable_fn @@ -490,19 +476,19 @@ rebindToStack name 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. + - 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* @@ -512,60 +498,56 @@ Probably *naughty* to look inside monad... \begin{code} nukeDeadBindings :: StgLiveVars -- All the *live* variables - -> Code + -> Code nukeDeadBindings live_vars = do - binds <- getBinds - let (dead_stk_slots, bs') = - dead_slots live_vars - [] [] - [ (cg_id b, b) | b <- varEnvElts binds ] - setBinds $ mkVarEnv bs' - freeStackSlots dead_stk_slots + binds <- getBinds + let (dead_stk_slots, bs') = + dead_slots 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 :: StgLiveVars - -> [(Id,CgIdInfo)] - -> [VirtualSpOffset] - -> [(Id,CgIdInfo)] - -> ([VirtualSpOffset], [(Id,CgIdInfo)]) + -> [(Id,CgIdInfo)] + -> [VirtualSpOffset] + -> [(Id,CgIdInfo)] + -> ([VirtualSpOffset], [(Id,CgIdInfo)]) -- dead_slots carries accumulating parameters for --- filtered bindings, dead slots +-- filtered bindings, dead slots dead_slots _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any dead_slots live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars = dead_slots live_vars ((v,i):fbs) ds bs - -- Live, so don't record it in dead slots - -- Instead keep it in the filtered bindings + -- 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 live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + VirStkLoc offset + | size > 0 + -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots live_vars fbs ds bs where size :: WordOff size = cgRepSizeW (cg_rep i) -\end{code} -\begin{code} 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] } -\end{code} + = do { binds <- getBinds + ; return [off | CgIdInfo { cg_stb = VirStkLoc off, + cg_rep = rep } <- varEnvElts binds, + isFollowableArg rep] } -\begin{code} getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)] getLiveStackBindings = do { binds <- getBinds @@ -575,3 +557,4 @@ getLiveStackBindings cg_rep = rep} <- [bind], isFollowableArg rep] } \end{code} + |