Implement unboxed sum primitive type
[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, getArgAmode_no_rubbish,
23 getNonVoidArgAmodes, getNonVoidArgAmodes_no_rubbish,
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 CmmExpr
39 import CmmUtils
40 import Control.Monad
41 import DynFlags
42 import Id
43 import MkGraph
44 import Name
45 import Outputable
46 import StgSyn
47 import UniqFM
48 import VarEnv
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 -- Use with care; if used inappropriately, it could break invariants.
60 unsafe_stripNV :: NonVoid a -> a
61 unsafe_stripNV (NonVoid a) = a
62
63 instance (Outputable a) => Outputable (NonVoid a) where
64 ppr (NonVoid a) = ppr a
65
66 nonVoidIds :: [Id] -> [NonVoid Id]
67 nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
68
69 -------------------------------------
70 -- Manipulating CgIdInfo
71 -------------------------------------
72
73 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
74 mkCgIdInfo id lf expr
75 = CgIdInfo { cg_id = id, cg_lf = lf
76 , cg_loc = CmmLoc expr }
77
78 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
79 litIdInfo dflags id lf lit
80 = CgIdInfo { cg_id = id, cg_lf = lf
81 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
82 where
83 tag = lfDynTag dflags lf
84
85 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
86 lneIdInfo dflags id regs
87 = CgIdInfo { cg_id = id, cg_lf = lf
88 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
89 where
90 lf = mkLFLetNoEscape
91 blk_id = mkBlockId (idUnique id)
92
93
94 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
95 rhsIdInfo id lf_info
96 = do dflags <- getDynFlags
97 reg <- newTemp (gcWord dflags)
98 return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
99
100 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
101 mkRhsInit dflags reg lf_info expr
102 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
103
104 idInfoToAmode :: CgIdInfo -> CmmExpr
105 -- Returns a CmmExpr for the *tagged* pointer
106 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
107 idInfoToAmode cg_info
108 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
109
110 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
111 -- A tag adds a byte offset to the pointer
112 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
113
114 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
115 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
116 maybeLetNoEscape _other = Nothing
117
118
119
120 ---------------------------------------------------------
121 -- The binding environment
122 --
123 -- There are three basic routines, for adding (addBindC),
124 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
125 ---------------------------------------------------------
126
127 addBindC :: CgIdInfo -> FCode ()
128 addBindC stuff_to_bind = do
129 binds <- getBinds
130 setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
131
132 addBindsC :: [CgIdInfo] -> FCode ()
133 addBindsC new_bindings = do
134 binds <- getBinds
135 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
136 binds
137 new_bindings
138 setBinds new_binds
139
140 getCgIdInfo :: Id -> FCode CgIdInfo
141 getCgIdInfo id
142 = do { dflags <- getDynFlags
143 ; local_binds <- getBinds -- Try local bindings first
144 ; case lookupVarEnv local_binds id of {
145 Just info -> return info ;
146 Nothing -> do {
147
148 -- Should be imported; make up a CgIdInfo for it
149 let name = idName id
150 ; if isExternalName name then
151 let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
152 in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
153 else
154 cgLookupPanic id -- Bug
155 }}}
156
157 cgLookupPanic :: Id -> FCode a
158 cgLookupPanic id
159 = do local_binds <- getBinds
160 pprPanic "StgCmmEnv: variable not found"
161 (vcat [ppr id,
162 text "local binds for:",
163 pprUFM local_binds $ \infos ->
164 vcat [ ppr (cg_id info) | info <- infos ]
165 ])
166
167
168 --------------------
169 getArgAmode :: NonVoid StgArg -> FCode CmmArg
170 getArgAmode (NonVoid (StgVarArg var)) =
171 do { info <- getCgIdInfo var; return (CmmExprArg (idInfoToAmode info)) }
172 getArgAmode (NonVoid (StgLitArg lit)) = liftM (CmmExprArg . CmmLit) $ cgLit lit
173 getArgAmode (NonVoid (StgRubbishArg ty)) = return (CmmRubbishArg ty)
174
175 getArgAmode_no_rubbish :: NonVoid StgArg -> FCode CmmExpr
176 getArgAmode_no_rubbish (NonVoid (StgVarArg var)) =
177 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
178 getArgAmode_no_rubbish (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
179 getArgAmode_no_rubbish arg@(NonVoid (StgRubbishArg _)) = pprPanic "getArgAmode_no_rubbish" (ppr arg)
180
181 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmArg]
182 -- NB: Filters out void args,
183 -- so the result list may be shorter than the argument list
184 getNonVoidArgAmodes [] = return []
185 getNonVoidArgAmodes (arg:args)
186 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
187 | otherwise = do { amode <- getArgAmode (NonVoid arg)
188 ; amodes <- getNonVoidArgAmodes args
189 ; return ( amode : amodes ) }
190
191 -- This version assumes arguments are not rubbish. I think this assumption holds
192 -- as long as we don't pass unboxed sums to primops and foreign fns.
193 getNonVoidArgAmodes_no_rubbish :: [StgArg] -> FCode [CmmExpr]
194 getNonVoidArgAmodes_no_rubbish
195 = mapM (getArgAmode_no_rubbish . NonVoid) . filter (not . isVoidRep . argPrimRep)
196
197
198 ------------------------------------------------------------------------
199 -- Interface functions for binding and re-binding names
200 ------------------------------------------------------------------------
201
202 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
203 -- Bind an Id to a fresh LocalReg
204 bindToReg nvid@(NonVoid id) lf_info
205 = do dflags <- getDynFlags
206 let reg = idToReg dflags nvid
207 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
208 return reg
209
210 rebindToReg :: NonVoid Id -> FCode LocalReg
211 -- Like bindToReg, but the Id is already in scope, so
212 -- get its LF info from the envt
213 rebindToReg nvid@(NonVoid id)
214 = do { info <- getCgIdInfo id
215 ; bindToReg nvid (cg_lf info) }
216
217 bindArgToReg :: NonVoid Id -> FCode LocalReg
218 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
219
220 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
221 bindArgsToRegs args = mapM bindArgToReg args
222
223 idToReg :: DynFlags -> NonVoid Id -> LocalReg
224 -- Make a register from an Id, typically a function argument,
225 -- free variable, or case binder
226 --
227 -- We re-use the Unique from the Id to make it easier to see what is going on
228 --
229 -- By now the Ids should be uniquely named; else one would worry
230 -- about accidental collision
231 idToReg dflags (NonVoid id)
232 = LocalReg (idUnique id)
233 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
234 _ -> primRepCmmType dflags (idPrimRep id))
235
236