Generalize CmmUnwind and pass unwind information through NCG
[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 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 BlockId
35 import CmmExpr
36 import CmmUtils
37 import DynFlags
38 import Id
39 import MkGraph
40 import Name
41 import Outputable
42 import StgSyn
43 import Type
44 import TysPrim
45 import UniqFM
46 import Util
47 import VarEnv
48
49 -------------------------------------
50 -- Manipulating CgIdInfo
51 -------------------------------------
52
53 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
54 mkCgIdInfo id lf expr
55 = CgIdInfo { cg_id = id, cg_lf = lf
56 , cg_loc = CmmLoc expr }
57
58 litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
59 litIdInfo dflags id lf lit
60 = CgIdInfo { cg_id = id, cg_lf = lf
61 , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
62 where
63 tag = lfDynTag dflags lf
64
65 lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
66 lneIdInfo dflags id regs
67 = CgIdInfo { cg_id = id, cg_lf = lf
68 , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
69 where
70 lf = mkLFLetNoEscape
71 blk_id = mkBlockId (idUnique id)
72
73
74 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
75 rhsIdInfo id lf_info
76 = do dflags <- getDynFlags
77 reg <- newTemp (gcWord dflags)
78 return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
79
80 mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
81 mkRhsInit dflags reg lf_info expr
82 = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
83
84 idInfoToAmode :: CgIdInfo -> CmmExpr
85 -- Returns a CmmExpr for the *tagged* pointer
86 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
87 idInfoToAmode cg_info
88 = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc
89
90 addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
91 -- A tag adds a byte offset to the pointer
92 addDynTag dflags expr tag = cmmOffsetB dflags expr tag
93
94 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
95 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
96 maybeLetNoEscape _other = Nothing
97
98
99
100 ---------------------------------------------------------
101 -- The binding environment
102 --
103 -- There are three basic routines, for adding (addBindC),
104 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
105 ---------------------------------------------------------
106
107 addBindC :: CgIdInfo -> FCode ()
108 addBindC stuff_to_bind = do
109 binds <- getBinds
110 setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
111
112 addBindsC :: [CgIdInfo] -> FCode ()
113 addBindsC new_bindings = do
114 binds <- getBinds
115 let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
116 binds
117 new_bindings
118 setBinds new_binds
119
120 getCgIdInfo :: Id -> FCode CgIdInfo
121 getCgIdInfo id
122 = do { dflags <- getDynFlags
123 ; local_binds <- getBinds -- Try local bindings first
124 ; case lookupVarEnv local_binds id of {
125 Just info -> return info ;
126 Nothing -> do {
127
128 -- Should be imported; make up a CgIdInfo for it
129 let name = idName id
130 ; if isExternalName name then
131 let ext_lbl
132 | isUnliftedType (idType id) =
133 -- An unlifted external Id must refer to a top-level
134 -- string literal. See Note [Bytes label] in CLabel.
135 ASSERT( idType id `eqType` addrPrimTy )
136 mkBytesLabel name
137 | otherwise = mkClosureLabel name $ idCafInfo id
138 in return $
139 litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
140 else
141 cgLookupPanic id -- Bug
142 }}}
143
144 cgLookupPanic :: Id -> FCode a
145 cgLookupPanic id
146 = do local_binds <- getBinds
147 pprPanic "StgCmmEnv: variable not found"
148 (vcat [ppr id,
149 text "local binds for:",
150 pprUFM local_binds $ \infos ->
151 vcat [ ppr (cg_id info) | info <- infos ]
152 ])
153
154
155 --------------------
156 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
157 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
158 getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
159
160 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
161 -- NB: Filters out void args,
162 -- so the result list may be shorter than the argument list
163 getNonVoidArgAmodes [] = return []
164 getNonVoidArgAmodes (arg:args)
165 | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
166 | otherwise = do { amode <- getArgAmode (NonVoid arg)
167 ; amodes <- getNonVoidArgAmodes args
168 ; return ( amode : amodes ) }
169
170
171 ------------------------------------------------------------------------
172 -- Interface functions for binding and re-binding names
173 ------------------------------------------------------------------------
174
175 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
176 -- Bind an Id to a fresh LocalReg
177 bindToReg nvid@(NonVoid id) lf_info
178 = do dflags <- getDynFlags
179 let reg = idToReg dflags nvid
180 addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
181 return reg
182
183 rebindToReg :: NonVoid Id -> FCode LocalReg
184 -- Like bindToReg, but the Id is already in scope, so
185 -- get its LF info from the envt
186 rebindToReg nvid@(NonVoid id)
187 = do { info <- getCgIdInfo id
188 ; bindToReg nvid (cg_lf info) }
189
190 bindArgToReg :: NonVoid Id -> FCode LocalReg
191 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
192
193 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
194 bindArgsToRegs args = mapM bindArgToReg args
195
196 idToReg :: DynFlags -> NonVoid Id -> LocalReg
197 -- Make a register from an Id, typically a function argument,
198 -- free variable, or case binder
199 --
200 -- We re-use the Unique from the Id to make it easier to see what is going on
201 --
202 -- By now the Ids should be uniquely named; else one would worry
203 -- about accidental collision
204 idToReg dflags (NonVoid id)
205 = LocalReg (idUnique id)
206 (primRepCmmType dflags (idPrimRep id))