compiler/codeGen/StgCmmEnv.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C-- code generation: the binding environment
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmEnv (
  10         CgIdInfo,
  11
  12         cgIdInfoId, cgIdInfoLF,
  13
  14         litIdInfo, lneIdInfo, regIdInfo,
  15         idInfoToAmode,
  16
  17         NonVoid(..), isVoidId, nonVoidIds,
  18
  19         addBindC, addBindsC,
  20
  21         bindArgsToRegs, bindToReg, rebindToReg,
  22         bindArgToReg, idToReg,
  23         getArgAmode, getNonVoidArgAmodes,
  24         getCgIdInfo,
  25         maybeLetNoEscape,
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import TyCon
  31 import StgCmmMonad
  32 import StgCmmUtils
  33 import StgCmmClosure
  34
  35 import CLabel
  36
  37 import BlockId
  38 import CmmExpr
  39 import CmmUtils
  40 import FastString
  41 import Id
  42 import VarEnv
  43 import Control.Monad
  44 import Name
  45 import StgSyn
  46 import Outputable
  47
  48 -------------------------------------
  49 --      Non-void types
  50 -------------------------------------
  51 -- We frequently need the invariant that an Id or a an argument
  52 -- is of a non-void type. This type is a witness to the invariant.
  53
  54 newtype NonVoid a = NonVoid a
  55   deriving (Eq, Show)
  56
  57 instance (Outputable a) => Outputable (NonVoid a) where
  58   ppr (NonVoid a) = ppr a
  59
  60 isVoidId :: Id -> Bool
  61 isVoidId = isVoidRep . idPrimRep
  62
  63 nonVoidIds :: [Id] -> [NonVoid Id]
  64 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
  65
  66 -------------------------------------
  67 --      Manipulating CgIdInfo
  68 -------------------------------------
  69
  70 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
  71 mkCgIdInfo id lf expr
  72   = CgIdInfo { cg_id = id, cg_loc = CmmLoc expr,
  73                cg_lf = lf, cg_rep = idPrimRep id,
  74                cg_tag = lfDynTag lf }
  75
  76 lneIdInfo :: Id -> [LocalReg] -> CgIdInfo
  77 lneIdInfo id regs
  78   = CgIdInfo { cg_id = id, cg_loc = LneLoc blk_id regs,
  79                cg_lf = lf, cg_rep = idPrimRep id,
  80                cg_tag = lfDynTag lf }
  81   where
  82     lf     = mkLFLetNoEscape
  83     blk_id = mkBlockId (idUnique id)
  84
  85 litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
  86 litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
  87   mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
  88
  89 regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
  90 regIdInfo id lf_info reg =
  91   mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
  92
  93 idInfoToAmode :: CgIdInfo -> CmmExpr
  94 -- Returns a CmmExpr for the *tagged* pointer
  95 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
  96 idInfoToAmode cg_info
  97   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))      -- LneLoc
  98
  99 addDynTag :: CmmExpr -> DynTag -> CmmExpr
 100 -- A tag adds a byte offset to the pointer
 101 addDynTag expr tag = cmmOffsetB expr tag
 102
 103 cgIdInfoId :: CgIdInfo -> Id
 104 cgIdInfoId = cg_id
 105
 106 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
 107 cgIdInfoLF = cg_lf
 108
 109 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
 110 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
 111 maybeLetNoEscape _other                                    = Nothing
 112
 113
 114
 115 ---------------------------------------------------------
 116 --      The binding environment
 117 --
 118 -- There are three basic routines, for adding (addBindC),
 119 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
 120 ---------------------------------------------------------
 121
 122 addBindC :: Id -> CgIdInfo -> FCode ()
 123 addBindC name stuff_to_bind = do
 124         binds <- getBinds
 125         setBinds $ extendVarEnv binds name stuff_to_bind
 126
 127 addBindsC :: [CgIdInfo] -> FCode ()
 128 addBindsC new_bindings = do
 129         binds <- getBinds
 130         let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
 131                               binds
 132                               new_bindings
 133         setBinds new_binds
 134
 135 getCgIdInfo :: Id -> FCode CgIdInfo
 136 getCgIdInfo id
 137   = do  {       -- Try local bindings first
 138         ; local_binds  <- getBinds
 139         ; case lookupVarEnv local_binds id of {
 140             Just info -> return info ;
 141             Nothing   -> do
 142
 143         {       -- Try top-level bindings
 144           static_binds <- getStaticBinds
 145         ; case lookupVarEnv static_binds id of {
 146             Just info -> return info ;
 147             Nothing   ->
 148
 149                 -- Should be imported; make up a CgIdInfo for it
 150         let
 151             name = idName id
 152         in
 153         if isExternalName name then do
 154             let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
 155             return (litIdInfo id (mkLFImported id) ext_lbl)
 156         else
 157         -- Bug
 158         cgLookupPanic id
 159         }}}}
 160
 161 cgLookupPanic :: Id -> FCode a
 162 cgLookupPanic id
 163   = do  static_binds <- getStaticBinds
 164         local_binds <- getBinds
 165         srt <- getSRTLabel
 166         pprPanic "StgCmmEnv: variable not found"
 167                 (vcat [ppr id,
 168                 ptext (sLit "static binds for:"),
 169                 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
 170                 ptext (sLit "local binds for:"),
 171                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
 172                 ptext (sLit "SRT label") <+> pprCLabel srt
 173               ])
 174
 175
 176 --------------------
 177 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
 178 getArgAmode (NonVoid (StgVarArg var))  =
 179   do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
 180 getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
 181 getArgAmode (NonVoid (StgTypeArg _))   = panic "getArgAmode: type arg"
 182
 183 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 184 -- NB: Filters out void args,
 185 --     so the result list may be shorter than the argument list
 186 getNonVoidArgAmodes [] = return []
 187 getNonVoidArgAmodes (arg:args)
 188   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
 189   | otherwise = do { amode  <- getArgAmode (NonVoid arg)
 190                    ; amodes <- getNonVoidArgAmodes args
 191                    ; return ( amode : amodes ) }
 192
 193
 194 ------------------------------------------------------------------------
 195 --      Interface functions for binding and re-binding names
 196 ------------------------------------------------------------------------
 197
 198 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 199 -- Bind an Id to a fresh LocalReg
 200 bindToReg nvid@(NonVoid id) lf_info
 201   = do  { let reg = idToReg nvid
 202         ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
 203         ; return reg }
 204
 205 rebindToReg :: NonVoid Id -> FCode LocalReg
 206 -- Like bindToReg, but the Id is already in scope, so
 207 -- get its LF info from the envt
 208 rebindToReg nvid@(NonVoid id)
 209   = do  { info <- getCgIdInfo id
 210         ; bindToReg nvid (cgIdInfoLF info) }
 211
 212 bindArgToReg :: NonVoid Id -> FCode LocalReg
 213 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 214
 215 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
 216 bindArgsToRegs args = mapM bindArgToReg args
 217
 218 idToReg :: NonVoid Id -> LocalReg
 219 -- Make a register from an Id, typically a function argument,
 220 -- free variable, or case binder
 221 --
 222 -- We re-use the Unique from the Id to make it easier to see what is going on
 223 --
 224 -- By now the Ids should be uniquely named; else one would worry
 225 -- about accidental collision
 226 idToReg (NonVoid id) = LocalReg (idUnique id)
 227                         (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
 228                                               _ -> primRepCmmType (idPrimRep id))
 229
 230