Replace calls to `ptext . sLit` with `text`
[ghc.git] / compiler / codeGen / StgCmmEnv.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Stg to C-- code generation: the binding environment
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10 module StgCmmEnv (
11 CgIdInfo,
12
13 litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
14 idInfoToAmode,
15
16 NonVoid(..), unsafe_stripNV, nonVoidIds,
17
18 addBindC, addBindsC,
19
20 bindArgsToRegs, bindToReg, rebindToReg,
21 bindArgToReg, idToReg,
22 getArgAmode, getNonVoidArgAmodes,
23 getCgIdInfo,
24 maybeLetNoEscape,
25 ) where
26
27 #include "HsVersions.h"
28
29 import TyCon
30 import StgCmmMonad
31 import StgCmmUtils
32 import StgCmmClosure
33
34 import CLabel
35
36 import DynFlags
37 import MkGraph
38 import BlockId
39 import CmmExpr
40 import CmmUtils
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 -- Use with care; if used inappropriately, it could break invariants.
58 unsafe_stripNV :: NonVoid a -> a
59 unsafe_stripNV (NonVoid a) = a
60
61 instance (Outputable a) => Outputable (NonVoid a) where
62 ppr (NonVoid a) = ppr a
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_lf = lf
74 , cg_loc = CmmLoc expr }
75
76 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
77 litIdInfo dflags id lf lit
78 = CgIdInfo { cg_id = id, cg_lf = lf
79 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
80 where
81 tag = lfDynTag dflags lf
82
83 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
84 lneIdInfo dflags id regs
85 = CgIdInfo { cg_id = id, cg_lf = lf
86 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
87 where
88 lf = mkLFLetNoEscape
89 blk_id = mkBlockId (idUnique id)
90
91
92 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
93 rhsIdInfo id lf_info
94 = do dflags <- getDynFlags
95 reg <- newTemp (gcWord dflags)
96 return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
97
98 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
99 mkRhsInit dflags reg lf_info expr
100 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
101
102 idInfoToAmode :: CgIdInfo -> CmmExpr
103 -- Returns a CmmExpr for the *tagged* pointer
104 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
105 idInfoToAmode cg_info
106 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
107
108 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
109 -- A tag adds a byte offset to the pointer
110 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
111
112 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
113 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
114 maybeLetNoEscape _other = Nothing
115
116
117
118 ---------------------------------------------------------
119 -- The binding environment
120 --
121 -- There are three basic routines, for adding (addBindC),
122 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
123 ---------------------------------------------------------
124
125 addBindC :: CgIdInfo -> FCode ()
126 addBindC stuff_to_bind = do
127 binds <- getBinds
128 setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
129
130 addBindsC :: [CgIdInfo] -> FCode ()
131 addBindsC new_bindings = do
132 binds <- getBinds
133 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
134 binds
135 new_bindings
136 setBinds new_binds
137
138 getCgIdInfo :: Id -> FCode CgIdInfo
139 getCgIdInfo id
140 = do { dflags <- getDynFlags
141 ; local_binds <- getBinds -- Try local bindings first
142 ; case lookupVarEnv local_binds id of {
143 Just info -> return info ;
144 Nothing -> do {
145
146 -- Should be imported; make up a CgIdInfo for it
147 let name = idName id
148 ; if isExternalName name then
149 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
150 in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
151 else
152 cgLookupPanic id -- Bug
153 }}}
154
155 cgLookupPanic :: Id -> FCode a
156 cgLookupPanic id
157 = do local_binds <- getBinds
158 pprPanic "StgCmmEnv: variable not found"
159 (vcat [ppr id,
160 text "local binds for:",
161 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
162 ])
163
164
165 --------------------
166 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
167 getArgAmode (NonVoid (StgVarArg var)) =
168 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
169 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
170
171 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
172 -- NB: Filters out void args,
173 -- so the result list may be shorter than the argument list
174 getNonVoidArgAmodes [] = return []
175 getNonVoidArgAmodes (arg:args)
176 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
177 | otherwise = do { amode <- getArgAmode (NonVoid arg)
178 ; amodes <- getNonVoidArgAmodes args
179 ; return ( amode : amodes ) }
180
181 ------------------------------------------------------------------------
182 -- Interface functions for binding and re-binding names
183 ------------------------------------------------------------------------
184
185 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
186 -- Bind an Id to a fresh LocalReg
187 bindToReg nvid@(NonVoid id) lf_info
188 = do dflags <- getDynFlags
189 let reg = idToReg dflags nvid
190 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
191 return reg
192
193 rebindToReg :: NonVoid Id -> FCode LocalReg
194 -- Like bindToReg, but the Id is already in scope, so
195 -- get its LF info from the envt
196 rebindToReg nvid@(NonVoid id)
197 = do { info <- getCgIdInfo id
198 ; bindToReg nvid (cg_lf info) }
199
200 bindArgToReg :: NonVoid Id -> FCode LocalReg
201 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
202
203 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
204 bindArgsToRegs args = mapM bindArgToReg args
205
206 idToReg :: DynFlags -> NonVoid Id -> LocalReg
207 -- Make a register from an Id, typically a function argument,
208 -- free variable, or case binder
209 --
210 -- We re-use the Unique from the Id to make it easier to see what is going on
211 --
212 -- By now the Ids should be uniquely named; else one would worry
213 -- about accidental collision
214 idToReg dflags (NonVoid id)
215 = LocalReg (idUnique id)
216 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
217 _ -> primRepCmmType dflags (idPrimRep id))
218
219