X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgBindery.lhs;h=d8675c53df0399859bc445e3ab0c12ee6f671565;hp=96735ef2112fb0e0a28821419a2a2511e41a40a0;hb=HEAD;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 96735ef..d8675c5 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CgBindery]{Utility functions related to doing @CgBindings@} @@ -10,7 +11,8 @@ module CgBindery ( cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - stableIdInfo, heapIdInfo, + stableIdInfo, heapIdInfo, + taggedStableIdInfo, taggedHeapIdInfo, letNoEscapeIdInfo, idInfoToAmode, addBindC, addBindsC, @@ -18,40 +20,41 @@ module CgBindery ( nukeVolatileBinds, nukeDeadBindings, getLiveStackSlots, + getLiveStackBindings, bindArgsToStack, rebindToStack, - bindNewToNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, + bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, + bindNewToTemp, getArgAmode, getArgAmodes, getCgIdInfo, getCAddrModeIfVolatile, getVolatileRegs, maybeLetNoEscape, ) where -#include "HsVersions.h" - import CgMonad -import CgHeapery ( getHpRelOffset ) -import CgStackery ( freeStackSlots, getSpRelOffset ) -import CgUtils ( cgLit, cmmOffsetW ) -import CLabel ( mkClosureLabel, pprCLabel ) -import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo ) - -import Cmm +import CgHeapery +import CgStackery +import CgUtils +import CLabel +import ClosureInfo +import Constants + +import OldCmm import PprCmm ( {- instance Outputable -} ) -import SMRep ( CgRep(..), WordOff, isFollowableArg, - isVoidArg, cgRepSizeW, argMachRep, - idCgRep, typeCgRep ) -import Id ( Id, idName ) +import SMRep +import Id +import DataCon import VarEnv -import VarSet ( varSetElems ) -import Literal ( literalType ) -import Maybes ( catMaybes ) -import Name ( isExternalName ) -import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg ) -import Unique ( Uniquable(..) ) -import UniqSet ( elementOfUniqSet ) +import VarSet +import Literal +import Maybes +import Name +import StgSyn +import Unique +import UniqSet import Outputable +import FastString + \end{code} @@ -80,23 +83,48 @@ data CgIdInfo , cg_rep :: CgRep , cg_vol :: VolatileLoc , cg_stb :: StableLoc - , cg_lf :: LambdaFormInfo } + , 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_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 con + + | otherwise + = funTagLFInfo lf + +voidIdInfo :: Id -> CgIdInfo voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc , cg_stb = VoidLoc, cg_lf = mkLFArgument id - , cg_rep = VoidArg } + , 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 VirtualHpOffset -- Cts of offset indirect from Node - -- ie *(Node+offset) + | VirNodeLoc ByteOff -- Cts of offset indirect from Node + -- ie *(Node+offset). + -- NB. Byte offset, because we subtract R1's + -- tag from the offset. + +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 } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -121,21 +149,21 @@ data StableLoc \begin{code} instance Outputable CgIdInfo where - ppr (CgIdInfo id rep vol stb lf) - = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb] + 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 + 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 + 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} %************************************************************************ @@ -145,23 +173,50 @@ instance Outputable StableLoc where %************************************************************************ \begin{code} +stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info + +heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info + +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 -nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info + +nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo +nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info + +regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info +taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo +taggedStableIdInfo id amode lf_info con + = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con + +taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon + -> CgIdInfo +taggedHeapIdInfo id offset lf_info con + = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con + +untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo +untagNodeIdInfo id offset lf_info tag + = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info + + idInfoToAmode :: CgIdInfo -> FCode CmmExpr idInfoToAmode info = case cg_vol info of { RegLoc reg -> returnFC (CmmReg reg) ; - VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ; - VirHpLoc hp_off -> getHpRelOffset hp_off ; + VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (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 amode + StableLoc amode -> returnFC $! maybeTag amode VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off ; return (CmmLoad sp_rel mach_rep) } @@ -177,6 +232,11 @@ idInfoToAmode info where mach_rep = argMachRep (cg_rep info) + maybeTag amode -- add the tag, if we have one + | tag == 0 = amode + | otherwise = cmmOffsetB amode tag + where tag = cg_tag info + cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id @@ -186,8 +246,9 @@ cgIdInfoLF = cg_lf cgIdInfoArgRep :: CgIdInfo -> CgRep cgIdInfoArgRep = cg_rep +maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off -maybeLetNoEscape other = Nothing +maybeLetNoEscape _ = Nothing \end{code} %************************************************************************ @@ -240,8 +301,7 @@ getCgIdInfo id name = idName id in if isExternalName name then do - this_pkg <- getThisPackage - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name)) + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then @@ -257,14 +317,14 @@ cgLookupPanic :: Id -> FCode a cgLookupPanic id = do static_binds <- getStaticBinds local_binds <- getBinds - srt <- getSRTLabel - pprPanic "cgPanic" +-- srt <- getSRTLabel + pprPanic "cgLookupPanic (probably invalid Core; try -dcore-lint)" (vcat [ppr id, - ptext SLIT("static binds for:"), + 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 + ptext (sLit "local binds for:"), + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] +-- ptext (sLit "SRT label") <+> pprCLabel srt ]) \end{code} @@ -302,7 +362,7 @@ getCAddrModeIfVolatile id NoStableLoc -> do -- Aha! So it is volatile! amode <- idInfoToAmode info return $ Just amode - a_stable_loc -> return Nothing } + _ -> return Nothing } \end{code} @getVolatileRegs@ gets a set of live variables, and returns a list of @@ -329,7 +389,7 @@ getVolatileRegs vars = do -- regs *really* need to be saved. case cg_stb info of NoStableLoc -> returnFC (Just reg) -- got one! - is_a_stable_loc -> do + _ -> do { -- has both volatile & stable locations; -- force it to rely on the stable location modifyBindC var nuke_vol_bind @@ -338,7 +398,7 @@ getVolatileRegs vars = do ; case cg_vol info of RegLoc (CmmGlobal reg) -> consider_reg reg VirNodeLoc _ -> consider_reg node - other_loc -> returnFC Nothing -- Local registers + _ -> returnFC Nothing -- Local registers } nuke_vol_bind info = info { cg_vol = NoVolatileLoc } @@ -389,16 +449,20 @@ bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code bindNewToNode id offset lf_info = addBindC id (nodeIdInfo id offset lf_info) +bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code +bindNewToUntagNode id offset lf_info tag + = addBindC id (untagNodeIdInfo 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 CmmReg +bindNewToTemp :: Id -> FCode LocalReg bindNewToTemp id - = do addBindC id (regIdInfo id temp_reg lf_info) + = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) return temp_reg where uniq = getUnique id - temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id))) + temp_reg = LocalReg uniq (argMachRep (idCgRep id)) lf_info = mkLFArgument id -- Always used of things we -- know nothing about @@ -462,7 +526,7 @@ dead_slots :: StgLiveVars -- dead_slots carries accumulating parameters for -- filtered bindings, dead slots -dead_slots live_vars fbs ds [] +dead_slots _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any dead_slots live_vars fbs ds ((v,i):bs) @@ -492,3 +556,14 @@ getLiveStackSlots cg_rep = rep } <- varEnvElts binds, isFollowableArg rep] } \end{code} + +\begin{code} +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}