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