Merge branch 'master' of darcs.haskell.org:/srv/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 -> CmmExpr -> FCode (CgIdInfo, CmmAGraph)
107 regIdInfo id lf_info expr
108 = do { reg <- newTemp (cmmExprType expr)
109 ; let init = mkAssign (CmmLocal reg)
110 (addDynTag expr (lfDynTag lf_info))
111 ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), init) }
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 :: CmmExpr -> DynTag -> CmmExpr
120 -- A tag adds a byte offset to the pointer
121 addDynTag expr tag = cmmOffsetB 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 return (litIdInfo id (mkLFImported id) ext_lbl)
176 else
177 -- Bug
178 cgLookupPanic id
179 }}}}
180
181 cgLookupPanic :: Id -> FCode a
182 cgLookupPanic id
183 = do static_binds <- getStaticBinds
184 local_binds <- getBinds
185 srt <- getSRTLabel
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 ptext (sLit "SRT label") <+> ppr srt
193 ])
194
195
196 --------------------
197 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
198 getArgAmode (NonVoid (StgVarArg var)) =
199 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
200 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
201
202 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
203 -- NB: Filters out void args,
204 -- so the result list may be shorter than the argument list
205 getNonVoidArgAmodes [] = return []
206 getNonVoidArgAmodes (arg:args)
207 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
208 | otherwise = do { amode <- getArgAmode (NonVoid arg)
209 ; amodes <- getNonVoidArgAmodes args
210 ; return ( amode : amodes ) }
211
212 ------------------------------------------------------------------------
213 -- Interface functions for binding and re-binding names
214 ------------------------------------------------------------------------
215
216 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
217 -- Bind an Id to a fresh LocalReg
218 bindToReg nvid@(NonVoid id) lf_info
219 = do { let reg = idToReg nvid
220 ; addBindC id (mkCgIdInfo 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 :: 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 (NonVoid id) = LocalReg (idUnique id)
245 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
246 _ -> primRepCmmType (idPrimRep id))
247
248