----------------------------------------------------------------------------- -- -- Stg to C-- code generation: the binding environment -- -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details module StgCmmEnv ( CgIdInfo, cgIdInfoId, cgIdInfoLF, litIdInfo, lneIdInfo, regIdInfo, idInfoToAmode, NonVoid(..), isVoidId, nonVoidIds, addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, getArgAmode, getNonVoidArgAmodes, getCgIdInfo, maybeLetNoEscape, ) where #include "HsVersions.h" import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure import CLabel import BlockId import CmmExpr import CmmUtils import MkGraph (CmmAGraph, mkAssign, (<*>)) import FastString import Id import VarEnv import Control.Monad import Name import StgSyn import DynFlags 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 ------------------------------------- mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo mkCgIdInfo id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr, cg_tag = lfDynTag lf } litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo id lf lit = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc (addDynTag (CmmLit lit) tag) , cg_tag = tag } where tag = lfDynTag lf lneIdInfo :: Id -> [LocalReg] -> CgIdInfo lneIdInfo id regs = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = LneLoc blk_id regs , cg_tag = lfDynTag lf } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) -- 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 }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc addDynTag :: CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer addDynTag expr tag = cmmOffsetB expr tag cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id cgIdInfoLF :: CgIdInfo -> LambdaFormInfo cgIdInfoLF = cg_lf 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 :: Id -> CgIdInfo -> FCode () addBindC name stuff_to_bind = do binds <- getBinds setBinds $ extendVarEnv binds name 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 { -- Try local bindings first ; local_binds <- getBinds ; case lookupVarEnv local_binds id of { Just info -> return info ; Nothing -> do { -- Try top-level bindings static_binds <- getStaticBinds ; case lookupVarEnv static_binds id of { Just info -> return info ; Nothing -> -- Should be imported; make up a CgIdInfo for it let name = idName id in if isExternalName name then do let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) return (litIdInfo id (mkLFImported id) ext_lbl) else -- Bug cgLookupPanic id }}}} cgLookupPanic :: Id -> FCode a cgLookupPanic id = do dflags <- getDynFlags static_binds <- getStaticBinds local_binds <- getBinds srt <- getSRTLabel pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, 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 (targetPlatform dflags) srt ]) -------------------- 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, -- 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 { let reg = idToReg nvid ; addBindC id (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 (cgIdInfoLF 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 :: 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 (NonVoid id) = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) _ -> primRepCmmType (idPrimRep id))