summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm/Env.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/StgToCmm/Env.hs')
-rw-r--r--compiler/GHC/StgToCmm/Env.hs208
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))