Merge remote-tracking branch 'origin/master' into tc-untouchables
[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
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module StgCmmEnv (
17 CgIdInfo,
18
19 cgIdInfoId, cgIdInfoLF,
20
21 litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
22 idInfoToAmode,
23
24 NonVoid(..), isVoidId, nonVoidIds,
25
26 addBindC, addBindsC,
27
28 bindArgsToRegs, bindToReg, rebindToReg,
29 bindArgToReg, idToReg,
30 getArgAmode, getNonVoidArgAmodes,
31 getCgIdInfo,
32 maybeLetNoEscape,
33 ) where
34
35 #include "HsVersions.h"
36
37 import TyCon
38 import StgCmmMonad
39 import StgCmmUtils
40 import StgCmmClosure
41
42 import CLabel
43
44 import DynFlags
45 import MkGraph
46 import BlockId
47 import CmmExpr
48 import CmmUtils
49 import FastString
50 import Id
51 import VarEnv
52 import Control.Monad
53 import Name
54 import StgSyn
55 import Outputable
56
57 -------------------------------------
58 -- Non-void types
59 -------------------------------------
60 -- We frequently need the invariant that an Id or a an argument
61 -- is of a non-void type. This type is a witness to the invariant.
62
63 newtype NonVoid a = NonVoid a
64 deriving (Eq, Show)
65
66 instance (Outputable a) => Outputable (NonVoid a) where
67 ppr (NonVoid a) = ppr a
68
69 isVoidId :: Id -> Bool
70 isVoidId = isVoidRep . idPrimRep
71
72 nonVoidIds :: [Id] -> [NonVoid Id]
73 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
74
75 -------------------------------------
76 -- Manipulating CgIdInfo
77 -------------------------------------
78
79 mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
80 mkCgIdInfo dflags id lf expr
81 = CgIdInfo { cg_id = id, cg_lf = lf
82 , cg_loc = CmmLoc expr,
83 cg_tag = lfDynTag dflags lf }
84
85 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
86 litIdInfo dflags id lf lit
87 = CgIdInfo { cg_id = id, cg_lf = lf
88 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag)
89 , cg_tag = tag }
90 where
91 tag = lfDynTag dflags lf
92
93 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
94 lneIdInfo dflags id regs
95 = CgIdInfo { cg_id = id, cg_lf = lf
96 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs)
97 , cg_tag = lfDynTag dflags lf }
98 where
99 lf = mkLFLetNoEscape
100 blk_id = mkBlockId (idUnique id)
101
102
103 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
104 rhsIdInfo id lf_info
105 = do dflags <- getDynFlags
106 reg <- newTemp (gcWord dflags)
107 return (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)), reg)
108
109 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
110 mkRhsInit dflags reg lf_info expr
111 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
112
113 idInfoToAmode :: CgIdInfo -> CmmExpr
114 -- Returns a CmmExpr for the *tagged* pointer
115 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
116 idInfoToAmode cg_info
117 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
118
119 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
120 -- A tag adds a byte offset to the pointer
121 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
122
123 cgIdInfoId :: CgIdInfo -> Id
124 cgIdInfoId = cg_id
125
126 cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
127 cgIdInfoLF = cg_lf
128
129 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
130 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
131 maybeLetNoEscape _other = Nothing
132
133
134
135 ---------------------------------------------------------
136 -- The binding environment
137 --
138 -- There are three basic routines, for adding (addBindC),
139 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
140 ---------------------------------------------------------
141
142 addBindC :: Id -> CgIdInfo -> FCode ()
143 addBindC name stuff_to_bind = do
144 binds <- getBinds
145 setBinds $ extendVarEnv binds name stuff_to_bind
146
147 addBindsC :: [CgIdInfo] -> FCode ()
148 addBindsC new_bindings = do
149 binds <- getBinds
150 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
151 binds
152 new_bindings
153 setBinds new_binds
154
155 getCgIdInfo :: Id -> FCode CgIdInfo
156 getCgIdInfo id
157 = do { -- Try local bindings first
158 ; local_binds <- getBinds
159 ; case lookupVarEnv local_binds id of {
160 Just info -> return info ;
161 Nothing -> do
162
163 { -- Try top-level bindings
164 static_binds <- getStaticBinds
165 ; case lookupVarEnv static_binds id of {
166 Just info -> return info ;
167 Nothing ->
168
169 -- Should be imported; make up a CgIdInfo for it
170 let
171 name = idName id
172 in
173 if isExternalName name then do
174 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
175 dflags <- getDynFlags
176 return (litIdInfo dflags id (mkLFImported id) ext_lbl)
177 else
178 -- Bug
179 cgLookupPanic id
180 }}}}
181
182 cgLookupPanic :: Id -> FCode a
183 cgLookupPanic id
184 = do static_binds <- getStaticBinds
185 local_binds <- getBinds
186 pprPanic "StgCmmEnv: variable not found"
187 (vcat [ppr id,
188 ptext (sLit "static binds for:"),
189 vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
190 ptext (sLit "local binds for:"),
191 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
192 ])
193
194
195 --------------------
196 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
197 getArgAmode (NonVoid (StgVarArg var)) =
198 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
199 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
200
201 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
202 -- NB: Filters out void args,
203 -- so the result list may be shorter than the argument list
204 getNonVoidArgAmodes [] = return []
205 getNonVoidArgAmodes (arg:args)
206 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
207 | otherwise = do { amode <- getArgAmode (NonVoid arg)
208 ; amodes <- getNonVoidArgAmodes args
209 ; return ( amode : amodes ) }
210
211 ------------------------------------------------------------------------
212 -- Interface functions for binding and re-binding names
213 ------------------------------------------------------------------------
214
215 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
216 -- Bind an Id to a fresh LocalReg
217 bindToReg nvid@(NonVoid id) lf_info
218 = do dflags <- getDynFlags
219 let reg = idToReg dflags nvid
220 addBindC id (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)))
221 return reg
222
223 rebindToReg :: NonVoid Id -> FCode LocalReg
224 -- Like bindToReg, but the Id is already in scope, so
225 -- get its LF info from the envt
226 rebindToReg nvid@(NonVoid id)
227 = do { info <- getCgIdInfo id
228 ; bindToReg nvid (cgIdInfoLF info) }
229
230 bindArgToReg :: NonVoid Id -> FCode LocalReg
231 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
232
233 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
234 bindArgsToRegs args = mapM bindArgToReg args
235
236 idToReg :: DynFlags -> NonVoid Id -> LocalReg
237 -- Make a register from an Id, typically a function argument,
238 -- free variable, or case binder
239 --
240 -- We re-use the Unique from the Id to make it easier to see what is going on
241 --
242 -- By now the Ids should be uniquely named; else one would worry
243 -- about accidental collision
244 idToReg dflags (NonVoid id)
245 = LocalReg (idUnique id)
246 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
247 _ -> primRepCmmType dflags (idPrimRep id))
248
249