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