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