Document some benign nondeterminism
[ghc.git] / compiler / codeGen / StgCmmEnv.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Stg to C-- code generation: the binding environment
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10 module StgCmmEnv (
11 CgIdInfo,
12
13 litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
14 idInfoToAmode,
15
16 NonVoid(..), unsafe_stripNV, nonVoidIds,
17
18 addBindC, addBindsC,
19
20 bindArgsToRegs, bindToReg, rebindToReg,
21 bindArgToReg, idToReg,
22 getArgAmode, getNonVoidArgAmodes,
23 getCgIdInfo,
24 maybeLetNoEscape,
25 ) where
26
27 #include "HsVersions.h"
28
29 import TyCon
30 import StgCmmMonad
31 import StgCmmUtils
32 import StgCmmClosure
33
34 import CLabel
35
36 import DynFlags
37 import MkGraph
38 import BlockId
39 import CmmExpr
40 import CmmUtils
41 import Id
42 import VarEnv
43 import Control.Monad
44 import Name
45 import StgSyn
46 import Outputable
47 import UniqFM
48
49 -------------------------------------
50 -- Non-void types
51 -------------------------------------
52 -- We frequently need the invariant that an Id or a an argument
53 -- is of a non-void type. This type is a witness to the invariant.
54
55 newtype NonVoid a = NonVoid a
56 deriving (Eq, Show)
57
58 -- Use with care; if used inappropriately, it could break invariants.
59 unsafe_stripNV :: NonVoid a -> a
60 unsafe_stripNV (NonVoid a) = a
61
62 instance (Outputable a) => Outputable (NonVoid a) where
63 ppr (NonVoid a) = ppr a
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_lf = lf
75 , cg_loc = CmmLoc expr }
76
77 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
78 litIdInfo dflags id lf lit
79 = CgIdInfo { cg_id = id, cg_lf = lf
80 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
81 where
82 tag = lfDynTag dflags lf
83
84 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
85 lneIdInfo dflags id regs
86 = CgIdInfo { cg_id = id, cg_lf = lf
87 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
88 where
89 lf = mkLFLetNoEscape
90 blk_id = mkBlockId (idUnique id)
91
92
93 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
94 rhsIdInfo id lf_info
95 = do dflags <- getDynFlags
96 reg <- newTemp (gcWord dflags)
97 return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
98
99 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
100 mkRhsInit dflags reg lf_info expr
101 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
102
103 idInfoToAmode :: CgIdInfo -> CmmExpr
104 -- Returns a CmmExpr for the *tagged* pointer
105 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
106 idInfoToAmode cg_info
107 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
108
109 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
110 -- A tag adds a byte offset to the pointer
111 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
112
113 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
114 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
115 maybeLetNoEscape _other = Nothing
116
117
118
119 ---------------------------------------------------------
120 -- The binding environment
121 --
122 -- There are three basic routines, for adding (addBindC),
123 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
124 ---------------------------------------------------------
125
126 addBindC :: CgIdInfo -> FCode ()
127 addBindC stuff_to_bind = do
128 binds <- getBinds
129 setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
130
131 addBindsC :: [CgIdInfo] -> FCode ()
132 addBindsC new_bindings = do
133 binds <- getBinds
134 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
135 binds
136 new_bindings
137 setBinds new_binds
138
139 getCgIdInfo :: Id -> FCode CgIdInfo
140 getCgIdInfo id
141 = do { dflags <- getDynFlags
142 ; local_binds <- getBinds -- Try local bindings first
143 ; case lookupVarEnv local_binds id of {
144 Just info -> return info ;
145 Nothing -> do {
146
147 -- Should be imported; make up a CgIdInfo for it
148 let name = idName id
149 ; if isExternalName name then
150 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
151 in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
152 else
153 cgLookupPanic id -- Bug
154 }}}
155
156 cgLookupPanic :: Id -> FCode a
157 cgLookupPanic id
158 = do local_binds <- getBinds
159 pprPanic "StgCmmEnv: variable not found"
160 (vcat [ppr id,
161 text "local binds for:",
162 pprUFM local_binds $ \infos ->
163 vcat [ ppr (cg_id info) | info <- infos ]
164 ])
165
166
167 --------------------
168 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
169 getArgAmode (NonVoid (StgVarArg var)) =
170 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
171 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
172
173 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
174 -- NB: Filters out void args,
175 -- so the result list may be shorter than the argument list
176 getNonVoidArgAmodes [] = return []
177 getNonVoidArgAmodes (arg:args)
178 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
179 | otherwise = do { amode <- getArgAmode (NonVoid arg)
180 ; amodes <- getNonVoidArgAmodes args
181 ; return ( amode : amodes ) }
182
183 ------------------------------------------------------------------------
184 -- Interface functions for binding and re-binding names
185 ------------------------------------------------------------------------
186
187 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
188 -- Bind an Id to a fresh LocalReg
189 bindToReg nvid@(NonVoid id) lf_info
190 = do dflags <- getDynFlags
191 let reg = idToReg dflags nvid
192 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
193 return reg
194
195 rebindToReg :: NonVoid Id -> FCode LocalReg
196 -- Like bindToReg, but the Id is already in scope, so
197 -- get its LF info from the envt
198 rebindToReg nvid@(NonVoid id)
199 = do { info <- getCgIdInfo id
200 ; bindToReg nvid (cg_lf info) }
201
202 bindArgToReg :: NonVoid Id -> FCode LocalReg
203 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
204
205 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
206 bindArgsToRegs args = mapM bindArgToReg args
207
208 idToReg :: DynFlags -> NonVoid Id -> LocalReg
209 -- Make a register from an Id, typically a function argument,
210 -- free variable, or case binder
211 --
212 -- We re-use the Unique from the Id to make it easier to see what is going on
213 --
214 -- By now the Ids should be uniquely named; else one would worry
215 -- about accidental collision
216 idToReg dflags (NonVoid id)
217 = LocalReg (idUnique id)
218 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
219 _ -> primRepCmmType dflags (idPrimRep id))
220
221