X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgBindery.lhs;h=d8675c53df0399859bc445e3ab0c12ee6f671565;hp=7447222d458c4da506a8f61fdf72ba80f511f7e4;hb=HEAD;hpb=6015a94f9108a502150565577b66c23650796639 diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 7447222..d8675c5 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -31,8 +31,6 @@ module CgBindery ( maybeLetNoEscape, ) where -#include "HsVersions.h" - import CgMonad import CgHeapery import CgStackery @@ -41,7 +39,7 @@ import CLabel import ClosureInfo import Constants -import Cmm +import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep import Id @@ -55,6 +53,7 @@ import StgSyn import Unique import UniqSet import Outputable +import FastString \end{code} @@ -88,6 +87,7 @@ data CgIdInfo , 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 } @@ -105,6 +105,7 @@ mkCgIdInfo id vol stb lf | 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_tag = 0 } @@ -119,6 +120,8 @@ data VolatileLoc -- These locations die across a call -- 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 } @@ -146,21 +149,21 @@ data StableLoc \begin{code} instance Outputable CgIdInfo where - ppr (CgIdInfo id rep vol stb lf _) -- TODO, pretty pring the tag info - = 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} %************************************************************************ @@ -170,17 +173,34 @@ 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 -> 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 @@ -226,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} %************************************************************************ @@ -280,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 @@ -297,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} @@ -342,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 @@ -369,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 @@ -378,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 } @@ -442,10 +462,7 @@ bindNewToTemp id 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 @@ -509,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)