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