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