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