X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmEnv.hs;h=369e1993aab3c27e7849aa8974c1ffee14b3b4e1;hp=c43bf80174dc6a5e471cb835dd05ea93ff3c40b1;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index c43bf80..369e199 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -14,6 +14,8 @@ module StgCmmEnv ( litIdInfo, lneIdInfo, regIdInfo, idInfoToAmode, + NonVoid(..), isVoidId, nonVoidIds, + addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, @@ -25,6 +27,7 @@ module StgCmmEnv ( #include "HsVersions.h" +import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure @@ -32,18 +35,34 @@ import StgCmmClosure import CLabel import BlockId -import Cmm +import CmmExpr import CmmUtils +import MkGraph (CmmAGraph, mkAssign, (<*>)) import FastString -import PprCmm ( {- instance Outputable -} ) import Id import VarEnv -import Maybes +import Control.Monad import Name import StgSyn import Outputable +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +isVoidId :: Id -> Bool +isVoidId = isVoidRep . idPrimRep + +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] ------------------------------------- -- Manipulating CgIdInfo @@ -65,15 +84,23 @@ lneIdInfo id regs blk_id = mkBlockId (idUnique id) litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit) - -regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo -regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)) +litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit) + mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info)) + +-- Because the register may be spilled to the stack in untagged form, we +-- modify the initialization code 'init' to immediately tag the +-- register, and store a plain register in the CgIdInfo. We allocate +-- a new register in order to keep single-assignment and help out the +-- inliner. -- EZY +regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph) +regIdInfo id lf_info reg init = do + reg' <- newTemp (localRegType reg) + let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init') idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag }) - = addDynTag e tag +idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc @@ -105,10 +132,10 @@ addBindC name stuff_to_bind = do binds <- getBinds setBinds $ extendVarEnv binds name stuff_to_bind -addBindsC :: [(Id, CgIdInfo)] -> FCode () +addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do binds <- getBinds - let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) + let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info) binds new_bindings setBinds new_binds @@ -155,10 +182,11 @@ cgLookupPanic id -------------------- -getArgAmode :: StgArg -> FCode CmmExpr -getArgAmode (StgVarArg var) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } -getArgAmode (StgLitArg lit) = return (CmmLit (mkSimpleLit lit)) -getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = + do { info <- getCgIdInfo var; return (idInfoToAmode info) } +getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit +getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg" getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, @@ -166,7 +194,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode arg + | otherwise = do { amode <- getArgAmode (NonVoid arg) ; amodes <- getNonVoidArgAmodes args ; return ( amode : amodes ) } @@ -175,27 +203,27 @@ getNonVoidArgAmodes (arg:args) -- Interface functions for binding and re-binding names ------------------------------------------------------------------------ -bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg -bindToReg id lf_info - = do { let reg = idToReg id - ; addBindC id (regIdInfo id lf_info reg) +bindToReg nvid@(NonVoid id) lf_info + = do { let reg = idToReg nvid + ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) ; return reg } -rebindToReg :: Id -> FCode LocalReg +rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt -rebindToReg id +rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg id (cgIdInfoLF info) } + ; bindToReg nvid (cgIdInfoLF info) } -bindArgToReg :: Id -> FCode LocalReg -bindArgToReg id = bindToReg id (mkLFArgument id) +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) -bindArgsToRegs :: [Id] -> FCode [LocalReg] +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: Id -> LocalReg +idToReg :: NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -203,7 +231,8 @@ idToReg :: Id -> LocalReg -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg id = LocalReg (idUnique id) - (primRepCmmType (idPrimRep id)) +idToReg (NonVoid id) = LocalReg (idUnique id) + (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) + _ -> primRepCmmType (idPrimRep id))