diff options
Diffstat (limited to 'compiler/GHC/StgToCmm/Env.hs')
| -rw-r--r-- | compiler/GHC/StgToCmm/Env.hs | 208 |
1 files changed, 208 insertions, 0 deletions
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs new file mode 100644 index 0000000000..e32c6a1ecb --- /dev/null +++ b/compiler/GHC/StgToCmm/Env.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation: the binding environment +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- +module GHC.StgToCmm.Env ( + CgIdInfo, + + litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, + idInfoToAmode, + + addBindC, addBindsC, + + bindArgsToRegs, bindToReg, rebindToReg, + bindArgToReg, idToReg, + getArgAmode, getNonVoidArgAmodes, + getCgIdInfo, + maybeLetNoEscape, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TyCon +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure + +import CLabel + +import BlockId +import CmmExpr +import CmmUtils +import DynFlags +import Id +import MkGraph +import Name +import Outputable +import StgSyn +import Type +import TysPrim +import UniqFM +import Util +import VarEnv + +------------------------------------- +-- Manipulating CgIdInfo +------------------------------------- + +mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo id lf expr + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc expr } + +litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo dflags id lf lit + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) } + where + tag = lfDynTag dflags lf + +lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo dflags id regs + = CgIdInfo { cg_id = id, cg_lf = lf + , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) } + where + lf = mkLFLetNoEscape + blk_id = mkBlockId (idUnique id) + + +rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) +rhsIdInfo id lf_info + = do dflags <- getDynFlags + reg <- newTemp (gcWord dflags) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) + +mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit dflags reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) + +idInfoToAmode :: CgIdInfo -> CmmExpr +-- Returns a CmmExpr for the *tagged* pointer +idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e +idInfoToAmode cg_info + = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc + +addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr +-- A tag adds a byte offset to the pointer +addDynTag dflags expr tag = cmmOffsetB dflags expr tag + +maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) +maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) +maybeLetNoEscape _other = Nothing + + + +--------------------------------------------------------- +-- The binding environment +-- +-- There are three basic routines, for adding (addBindC), +-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. +--------------------------------------------------------- + +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do + binds <- getBinds + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind + +addBindsC :: [CgIdInfo] -> FCode () +addBindsC new_bindings = do + binds <- getBinds + let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info) + binds + new_bindings + setBinds new_binds + +getCgIdInfo :: Id -> FCode CgIdInfo +getCgIdInfo id + = do { dflags <- getDynFlags + ; local_binds <- getBinds -- Try local bindings first + ; case lookupVarEnv local_binds id of { + Just info -> return info ; + Nothing -> do { + + -- Should be imported; make up a CgIdInfo for it + let name = idName id + ; if isExternalName name then + let ext_lbl + | isUnliftedType (idType id) = + -- An unlifted external Id must refer to a top-level + -- string literal. See Note [Bytes label] in CLabel. + ASSERT( idType id `eqType` addrPrimTy ) + mkBytesLabel name + | otherwise = mkClosureLabel name $ idCafInfo id + in return $ + litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl) + else + cgLookupPanic id -- Bug + }}} + +cgLookupPanic :: Id -> FCode a +cgLookupPanic id + = do local_binds <- getBinds + pprPanic "GHC.StgToCmm.Env: variable not found" + (vcat [ppr id, + text "local binds for:", + pprUFM local_binds $ \infos -> + vcat [ ppr (cg_id info) | info <- infos ] + ]) + + +-------------------- +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var +getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit + +getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] +-- NB: Filters out void args, +-- so the result list may be shorter than the argument list +getNonVoidArgAmodes [] = return [] +getNonVoidArgAmodes (arg:args) + | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args + | otherwise = do { amode <- getArgAmode (NonVoid arg) + ; amodes <- getNonVoidArgAmodes args + ; return ( amode : amodes ) } + + +------------------------------------------------------------------------ +-- Interface functions for binding and re-binding names +------------------------------------------------------------------------ + +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg +-- Bind an Id to a fresh LocalReg +bindToReg nvid@(NonVoid id) lf_info + = do dflags <- getDynFlags + let reg = idToReg dflags nvid + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + return reg + +rebindToReg :: NonVoid Id -> FCode LocalReg +-- Like bindToReg, but the Id is already in scope, so +-- get its LF info from the envt +rebindToReg nvid@(NonVoid id) + = do { info <- getCgIdInfo id + ; bindToReg nvid (cg_lf info) } + +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) + +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] +bindArgsToRegs args = mapM bindArgToReg args + +idToReg :: DynFlags -> NonVoid Id -> LocalReg +-- Make a register from an Id, typically a function argument, +-- free variable, or case binder +-- +-- We re-use the Unique from the Id to make it easier to see what is going on +-- +-- By now the Ids should be uniquely named; else one would worry +-- about accidental collision +idToReg dflags (NonVoid id) + = LocalReg (idUnique id) + (primRepCmmType dflags (idPrimRep id)) |