cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
- stableIdInfo, heapIdInfo,
+ stableIdInfo, heapIdInfo,
+ taggedStableIdInfo, taggedHeapIdInfo,
letNoEscapeIdInfo, idInfoToAmode,
addBindC, addBindsC,
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
+ getLiveStackBindings,
bindArgsToStack, rebindToStack,
- bindNewToNode, bindNewToReg, bindArgsToRegs,
+ bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp,
getArgAmode, getArgAmodes,
getCgIdInfo,
maybeLetNoEscape,
) where
-#include "HsVersions.h"
-
import CgMonad
import CgHeapery
import CgStackery
import CgUtils
import CLabel
import ClosureInfo
+import Constants
-import Cmm
+import OldCmm
import PprCmm ( {- instance Outputable -} )
import SMRep
import Id
+import DataCon
import VarEnv
import VarSet
import Literal
import Unique
import UniqSet
import Outputable
+import FastString
+
\end{code}
, 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
\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}
%************************************************************************
%************************************************************************
\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) }
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
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}
%************************************************************************
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
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}
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
-- 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
; 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 }
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.
return temp_reg
where
uniq = getUnique id
- temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
- kind = if isFollowableArg (idCgRep id)
- then KindPtr
- else KindNonPtr
+ temp_reg = LocalReg uniq (argMachRep (idCgRep id))
lf_info = mkLFArgument id -- Always used of things we
-- know nothing about
-- 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)
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}
projects / ghc-hetmet.git / blobdiff