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