Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape
[ghc.git] / compiler / simplStg / UnariseStg.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
3
4
5 Note [Unarisation]
6 ~~~~~~~~~~~~~~~~~~
7
8 The idea of this pass is to translate away *all* unboxed-tuple binders. So for example:
9
10 f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
11 ==>
12 f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
13
14 It is important that we do this at the STG level and NOT at the core level
15 because it would be very hard to make this pass Core-type-preserving.
16
17 STG fed to the code generators *must* be unarised because the code generators do
18 not support unboxed tuple binders natively.
19
20
21 Note [Unarisation and arity]
22 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
23
24 Because of unarisation, the arity that will be recorded in the generated info table
25 for an Id may be larger than the idArity. Instead we record what we call the RepArity,
26 which is the Arity taking into account any expanded arguments, and corresponds to
27 the number of (possibly-void) *registers* arguments will arrive in.
28 -}
29
30 {-# LANGUAGE CPP #-}
31
32 module UnariseStg (unarise) where
33
34 #include "HsVersions.h"
35
36 import CoreSyn
37 import StgSyn
38 import VarEnv
39 import UniqSupply
40 import Id
41 import MkId (realWorldPrimId)
42 import Type
43 import TysWiredIn
44 import DataCon
45 import OccName
46 import Name
47 import Util
48 import Outputable
49 import BasicTypes
50
51
52 -- | A mapping from unboxed-tuple binders to the Ids they were expanded to.
53 --
54 -- INVARIANT: Ids in the range don't have unboxed tuple types.
55 --
56 -- Those in-scope variables without unboxed-tuple types are not present in
57 -- the domain of the mapping at all.
58 type UnariseEnv = VarEnv [Id]
59
60 ubxTupleId0 :: Id
61 ubxTupleId0 = dataConWorkId (tupleDataCon Unboxed 0)
62
63 unarise :: UniqSupply -> [StgBinding] -> [StgBinding]
64 unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSupply us) binds
65 where -- See Note [Nullary unboxed tuple] in Type.hs
66 init_env = unitVarEnv ubxTupleId0 [realWorldPrimId]
67
68 unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding
69 unariseBinding us rho bind = case bind of
70 StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs)
71 StgRec xrhss -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs))
72 (listSplitUniqSupply us) xrhss
73
74 unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
75 unariseRhs us rho rhs = case rhs of
76 StgRhsClosure ccs b_info fvs update_flag args expr
77 -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
78 args' (unariseExpr us' rho' expr)
79 where (us', rho', args') = unariseIdBinders us rho args
80 StgRhsCon ccs con args
81 -> StgRhsCon ccs con (unariseArgs rho args)
82
83 ------------------------
84 unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr
85 unariseExpr _ rho (StgApp f args)
86 | null args
87 , UbxTupleRep tys <- repType (idType f)
88 = -- Particularly important where (##) is concerned
89 -- See Note [Nullary unboxed tuple]
90 StgConApp (tupleDataCon Unboxed (length tys))
91 (map StgVarArg (unariseId rho f))
92
93 | otherwise
94 = StgApp f (unariseArgs rho args)
95
96 unariseExpr _ _ (StgLit l)
97 = StgLit l
98
99 unariseExpr _ rho (StgConApp dc args)
100 | isUnboxedTupleCon dc = StgConApp (tupleDataCon Unboxed (length args')) args'
101 | otherwise = StgConApp dc args'
102 where
103 args' = unariseArgs rho args
104
105 unariseExpr _ rho (StgOpApp op args ty)
106 = StgOpApp op (unariseArgs rho args) ty
107
108 unariseExpr us rho (StgLam xs e)
109 = StgLam xs' (unariseExpr us' rho' e)
110 where
111 (us', rho', xs') = unariseIdBinders us rho xs
112
113 unariseExpr us rho (StgCase e bndr alt_ty alts)
114 = StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
115 where
116 (us1, us2) = splitUniqSupply us
117 alts' = unariseAlts us2 rho alt_ty bndr alts
118
119 unariseExpr us rho (StgLet bind e)
120 = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
121 where
122 (us1, us2) = splitUniqSupply us
123
124 unariseExpr us rho (StgLetNoEscape bind e)
125 = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
126 where
127 (us1, us2) = splitUniqSupply us
128
129 unariseExpr us rho (StgTick tick e)
130 = StgTick tick (unariseExpr us rho e)
131
132 ------------------------
133 unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> [StgAlt] -> [StgAlt]
134 unariseAlts us rho (UbxTupAlt n) bndr [(DEFAULT, [], [], e)]
135 = [(DataAlt (tupleDataCon Unboxed n), ys, uses, unariseExpr us2' rho' e)]
136 where
137 (us2', rho', ys) = unariseIdBinder us rho bndr
138 uses = replicate (length ys) (not (isDeadBinder bndr))
139
140 unariseAlts us rho (UbxTupAlt n) bndr [(DataAlt _, ys, uses, e)]
141 = [(DataAlt (tupleDataCon Unboxed n), ys', uses', unariseExpr us2' rho'' e)]
142 where
143 (us2', rho', ys', uses') = unariseUsedIdBinders us rho ys uses
144 rho'' = extendVarEnv rho' bndr ys'
145
146 unariseAlts _ _ (UbxTupAlt _) _ alts
147 = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts)
148
149 unariseAlts us rho _ _ alts
150 = zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts
151
152 --------------------------
153 unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt
154 unariseAlt us rho (con, xs, uses, e)
155 = (con, xs', uses', unariseExpr us' rho' e)
156 where
157 (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
158
159 ------------------------
160 unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg]
161 unariseArgs rho = concatMap (unariseArg rho)
162
163 unariseArg :: UnariseEnv -> StgArg -> [StgArg]
164 unariseArg rho (StgVarArg x) = map StgVarArg (unariseId rho x)
165 unariseArg _ (StgLitArg l) = [StgLitArg l]
166
167 unariseIds :: UnariseEnv -> [Id] -> [Id]
168 unariseIds rho = concatMap (unariseId rho)
169
170 unariseId :: UnariseEnv -> Id -> [Id]
171 unariseId rho x
172 | Just ys <- lookupVarEnv rho x
173 = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0
174 , text "unariseId: not unboxed tuple" <+> ppr x )
175 ys
176
177 | otherwise
178 = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True
179 , text "unariseId: was unboxed tuple" <+> ppr x )
180 [x]
181
182 unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool]
183 -> (UniqSupply, UnariseEnv, [Id], [Bool])
184 unariseUsedIdBinders us rho xs uses
185 = case mapAccumL2 do_one us rho (zipEqual "unariseUsedIdBinders" xs uses) of
186 (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess))
187 where
188 do_one us rho (x, use) = third3 (map (flip (,) use)) (unariseIdBinder us rho x)
189
190 unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id])
191 unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs
192
193 unariseIdBinder :: UniqSupply -> UnariseEnv -> Id -> (UniqSupply, UnariseEnv, [Id])
194 unariseIdBinder us rho x = case repType (idType x) of
195 UnaryRep _ -> (us, rho, [x])
196 UbxTupleRep tys -> let (us0, us1) = splitUniqSupply us
197 ys = unboxedTupleBindersFrom us0 x tys
198 rho' = extendVarEnv rho x ys
199 in (us1, rho', ys)
200
201 unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
202 unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
203 where fs = occNameFS (getOccName x)