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 MkGraph (CmmAGraph, mkAssign, (<*>))
  41 import FastString
  42 import Id
  43 import VarEnv
  44 import Control.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 -- Because the register may be spilled to the stack in untagged form, we
  91 -- modify the initialization code 'init' to immediately tag the
  92 -- register, and store a plain register in the CgIdInfo.  We allocate
  93 -- a new register in order to keep single-assignment and help out the
  94 -- inliner. -- EZY
  95 regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph)
  96 regIdInfo id lf_info reg init = do
  97   reg' <- newTemp (localRegType reg)
  98   let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
  99   return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init')
 100
 101 idInfoToAmode :: CgIdInfo -> CmmExpr
 102 -- Returns a CmmExpr for the *tagged* pointer
 103 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
 104 idInfoToAmode cg_info
 105   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))      -- LneLoc
 106
 107 addDynTag :: CmmExpr -> DynTag -> CmmExpr
 108 -- A tag adds a byte offset to the pointer
 109 addDynTag expr tag = cmmOffsetB expr tag
 110
 111 cgIdInfoId :: CgIdInfo -> Id
 112 cgIdInfoId = cg_id
 113
 114 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
 115 cgIdInfoLF = cg_lf
 116
 117 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
 118 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
 119 maybeLetNoEscape _other                                    = Nothing
 120
 121
 122
 123 ---------------------------------------------------------
 124 --      The binding environment
 125 --
 126 -- There are three basic routines, for adding (addBindC),
 127 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
 128 ---------------------------------------------------------
 129
 130 addBindC :: Id -> CgIdInfo -> FCode ()
 131 addBindC name stuff_to_bind = do
 132         binds <- getBinds
 133         setBinds $ extendVarEnv binds name stuff_to_bind
 134
 135 addBindsC :: [CgIdInfo] -> FCode ()
 136 addBindsC new_bindings = do
 137         binds <- getBinds
 138         let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
 139                               binds
 140                               new_bindings
 141         setBinds new_binds
 142
 143 getCgIdInfo :: Id -> FCode CgIdInfo
 144 getCgIdInfo id
 145   = do  {       -- Try local bindings first
 146         ; local_binds  <- getBinds
 147         ; case lookupVarEnv local_binds id of {
 148             Just info -> return info ;
 149             Nothing   -> do
 150
 151         {       -- Try top-level bindings
 152           static_binds <- getStaticBinds
 153         ; case lookupVarEnv static_binds id of {
 154             Just info -> return info ;
 155             Nothing   ->
 156
 157                 -- Should be imported; make up a CgIdInfo for it
 158         let
 159             name = idName id
 160         in
 161         if isExternalName name then do
 162             let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
 163             return (litIdInfo id (mkLFImported id) ext_lbl)
 164         else
 165         -- Bug
 166         cgLookupPanic id
 167         }}}}
 168
 169 cgLookupPanic :: Id -> FCode a
 170 cgLookupPanic id
 171   = do  static_binds <- getStaticBinds
 172         local_binds <- getBinds
 173         srt <- getSRTLabel
 174         pprPanic "StgCmmEnv: variable not found"
 175                 (vcat [ppr id,
 176                 ptext (sLit "static binds for:"),
 177                 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
 178                 ptext (sLit "local binds for:"),
 179                 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
 180                 ptext (sLit "SRT label") <+> pprCLabel srt
 181               ])
 182
 183
 184 --------------------
 185 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
 186 getArgAmode (NonVoid (StgVarArg var))  =
 187   do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
 188 getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
 189 getArgAmode (NonVoid (StgTypeArg _))   = panic "getArgAmode: type arg"
 190
 191 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 192 -- NB: Filters out void args,
 193 --     so the result list may be shorter than the argument list
 194 getNonVoidArgAmodes [] = return []
 195 getNonVoidArgAmodes (arg:args)
 196   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
 197   | otherwise = do { amode  <- getArgAmode (NonVoid arg)
 198                    ; amodes <- getNonVoidArgAmodes args
 199                    ; return ( amode : amodes ) }
 200
 201
 202 ------------------------------------------------------------------------
 203 --      Interface functions for binding and re-binding names
 204 ------------------------------------------------------------------------
 205
 206 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 207 -- Bind an Id to a fresh LocalReg
 208 bindToReg nvid@(NonVoid id) lf_info
 209   = do  { let reg = idToReg nvid
 210         ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
 211         ; return reg }
 212
 213 rebindToReg :: NonVoid Id -> FCode LocalReg
 214 -- Like bindToReg, but the Id is already in scope, so
 215 -- get its LF info from the envt
 216 rebindToReg nvid@(NonVoid id)
 217   = do  { info <- getCgIdInfo id
 218         ; bindToReg nvid (cgIdInfoLF info) }
 219
 220 bindArgToReg :: NonVoid Id -> FCode LocalReg
 221 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 222
 223 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
 224 bindArgsToRegs args = mapM bindArgToReg args
 225
 226 idToReg :: NonVoid Id -> LocalReg
 227 -- Make a register from an Id, typically a function argument,
 228 -- free variable, or case binder
 229 --
 230 -- We re-use the Unique from the Id to make it easier to see what is going on
 231 --
 232 -- By now the Ids should be uniquely named; else one would worry
 233 -- about accidental collision
 234 idToReg (NonVoid id) = LocalReg (idUnique id)
 235                         (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
 236                                               _ -> primRepCmmType (idPrimRep id))
 237
 238