Support MO_{Add,Sub}IntC and MO_Add2 in the LLVM backend
[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 FastString
42 import Id
43 import VarEnv
44 import Control.Monad
45 import Name
46 import StgSyn
47 import Outputable
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 ptext (sLit "local binds for:"),
162 vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
163 ])
164
165
166 --------------------
167 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
168 getArgAmode (NonVoid (StgVarArg var)) =
169 do { info <- getCgIdInfo var; return (idInfoToAmode info) }
170 getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit
171
172 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
173 -- NB: Filters out void args,
174 -- so the result list may be shorter than the argument list
175 getNonVoidArgAmodes [] = return []
176 getNonVoidArgAmodes (arg:args)
177 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
178 | otherwise = do { amode <- getArgAmode (NonVoid arg)
179 ; amodes <- getNonVoidArgAmodes args
180 ; return ( amode : amodes ) }
181
182 ------------------------------------------------------------------------
183 -- Interface functions for binding and re-binding names
184 ------------------------------------------------------------------------
185
186 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
187 -- Bind an Id to a fresh LocalReg
188 bindToReg nvid@(NonVoid id) lf_info
189 = do dflags <- getDynFlags
190 let reg = idToReg dflags nvid
191 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
192 return reg
193
194 rebindToReg :: NonVoid Id -> FCode LocalReg
195 -- Like bindToReg, but the Id is already in scope, so
196 -- get its LF info from the envt
197 rebindToReg nvid@(NonVoid id)
198 = do { info <- getCgIdInfo id
199 ; bindToReg nvid (cg_lf info) }
200
201 bindArgToReg :: NonVoid Id -> FCode LocalReg
202 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
203
204 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
205 bindArgsToRegs args = mapM bindArgToReg args
206
207 idToReg :: DynFlags -> NonVoid Id -> LocalReg
208 -- Make a register from an Id, typically a function argument,
209 -- free variable, or case binder
210 --
211 -- We re-use the Unique from the Id to make it easier to see what is going on
212 --
213 -- By now the Ids should be uniquely named; else one would worry
214 -- about accidental collision
215 idToReg dflags (NonVoid id)
216 = LocalReg (idUnique id)
217 (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
218 _ -> primRepCmmType dflags (idPrimRep id))
219
220