----------------------------------------------------------------------------- -- -- 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, getCgIdInfo, getCgInfo_maybe, maybeLetNoEscape, ) where import GHC.Prelude import GHC.Platform import GHC.StgToCmm.Monad import GHC.StgToCmm.Closure import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM import GHC.Types.Var.Env import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Builtin.Names (getUnique) ------------------------------------- -- Manipulating CgIdInfo ------------------------------------- mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo mkCgIdInfo id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr } litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo platform id lf lit = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } where tag = lfDynTag platform lf lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo platform id regs = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = LneLoc blk_id (map (idToReg platform) regs) } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info = do platform <- getPlatform reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph mkRhsInit platform reg lf_info expr = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform 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 -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr addDynTag = cmmOffsetB 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 -- Inside GHC the average module creates 385 external references -- with notable cgIdInfo (so not generated by mkLFArgument). -- On average 200 of these are covered by True/False/[] -- and nullary constructors make up ~80. -- One would think it would be worthwhile to cache these. -- Sadly it's not. See #16937 getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id = do { platform <- getPlatform ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $ return info ; Nothing -> do { -- Should be imported; make up a CgIdInfo for it let name = idName id ; if isExternalName name then let ext_lbl | isBoxedType (idType id) = mkClosureLabel name $ idCafInfo id | isUnliftedType (idType id) -- An unlifted external Id must refer to a top-level -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel". = assert (idType id `eqType` addrPrimTy) $ mkBytesLabel name | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug }}} -- | Retrieve cg info for a name if it already exists. getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo) getCgInfo_maybe name = do { local_binds <- getBinds -- Try local bindings first ; return $ lookupVarEnv_Directly local_binds (getUnique name) } 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 ] ]) ------------------------------------------------------------------------ -- 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 platform <- getPlatform let reg = idToReg platform 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 = mapM bindArgToReg idToReg :: Platform -> 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 platform (NonVoid id) = LocalReg (idUnique id) (primRepCmmType platform (idPrimRep id))