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