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