X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgBindery.lhs;h=d8675c53df0399859bc445e3ab0c12ee6f671565;hp=0d76f8274e035f251f5f03c5a1b92659ee2ace6b;hb=HEAD;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 0d76f82..d8675c5 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -5,13 +5,6 @@ \section[CgBindery]{Utility functions related to doing @CgBindings@} \begin{code} -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module CgBindery ( CgBindings, CgIdInfo, StableLoc, VolatileLoc, @@ -38,8 +31,6 @@ module CgBindery ( maybeLetNoEscape, ) where -#include "HsVersions.h" - import CgMonad import CgHeapery import CgStackery @@ -48,7 +39,7 @@ import CLabel import ClosureInfo import Constants -import Cmm +import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep import Id @@ -62,6 +53,7 @@ import StgSyn import Unique import UniqSet import Outputable +import FastString \end{code} @@ -95,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 } @@ -112,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 } @@ -126,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 } @@ -153,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} %************************************************************************ @@ -177,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 @@ -233,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} %************************************************************************ @@ -287,7 +301,7 @@ getCgIdInfo id name = idName id in if isExternalName name then do - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name)) + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then @@ -303,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} @@ -348,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 @@ -375,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 @@ -384,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 } @@ -448,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 @@ -515,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)