Implement unboxed sum primitive type
[ghc.git] / compiler / simplStg / UnariseStg.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
3
4 Note [Unarisation]
5 ~~~~~~~~~~~~~~~~~~
6 The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
7 binders. So for example:
8
9 f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
10
11 ==>
12
13 f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
14
15 It is important that we do this at the STG level and NOT at the Core level
16 because it would be very hard to make this pass Core-type-preserving. In this
17 example the type of 'f' changes, for example.
18
19 STG fed to the code generators *must* be unarised because the code generators do
20 not support unboxed tuple and unboxed sum binders natively.
21
22 In more detail: (see next note for unboxed sums)
23
24 Suppose that a variable x : (# t1, t2 #).
25
26 * At the binding site for x, make up fresh vars x1:t1, x2:t2
27
28 * Extend the UnariseEnv x :-> MultiVal [x1,x2]
29
30 * Replace the binding with a curried binding for x1,x2
31
32 Lambda: \x.e ==> \x1 x2. e
33 Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e
34
35 * Replace argument occurrences with a sequence of args via a lookup in
36 UnariseEnv
37
38 f a b x c d ==> f a b x1 x2 c d
39
40 * Replace tail-call occurrences with an unboxed tuple via a lookup in
41 UnariseEnv
42
43 x ==> (# x1, x2 #)
44
45 So, for example
46
47 f x = x ==> f x1 x2 = (# x1, x2 #)
48
49 * We /always/ eliminate a case expression when
50
51 - It scrutinises an unboxed tuple or unboxed sum
52
53 - The scrutinee is a variable (or when it is an explicit tuple, but the
54 simplifier eliminates those)
55
56 The case alternative (there can be only one) can be one of these two
57 things:
58
59 - An unboxed tuple pattern. e.g.
60
61 case v of x { (# x1, x2, x3 #) -> ... }
62
63 Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
64 environment with
65
66 x :-> MultiVal [t1,t2,t3]
67 x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
68
69 - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
70
71 By the end of this pass, we only have unboxed tuples in return positions.
72 Unboxed sums are completely eliminated, see next note.
73
74 Note [Translating unboxed sums to unboxed tuples]
75 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 Unarise also eliminates unboxed sum binders, and translates unboxed sums in
77 return positions to unboxed tuples. We want to overlap fields of a sum when
78 translating it to a tuple to have efficient memory layout. When translating a
79 sum pattern to a tuple pattern, we need to translate it so that binders of sum
80 alternatives will be mapped to right arguments after the term translation. So
81 translation of sum DataCon applications to tuple DataCon applications and
82 translation of sum patterns to tuple patterns need to be in sync.
83
84 These translations work like this. Suppose we have
85
86 (# x1 | | ... #) :: (# t1 | t2 | ... #)
87
88 remember that t1, t2 ... can be sums and tuples too. So we first generate
89 layouts of those. Then we "merge" layouts of each alternative, which gives us a
90 sum layout with best overlapping possible.
91
92 Layout of a flat type 'ty1' is just [ty1].
93 Layout of a tuple is just concatenation of layouts of its fields.
94
95 For layout of a sum type,
96
97 - We first get layouts of all alternatives.
98 - We sort these layouts based on their "slot types".
99 - We merge all the alternatives.
100
101 For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
102
103 - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]
104 - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]
105 - Merge all alternatives together: [ Ptr, Word, Word ]
106
107 We add a slot for the tag to the first position. So our tuple type is
108
109 (# Tag#, Any, Word#, Word# #)
110 (we use Any for pointer slots)
111
112 Now, any term of this sum type needs to generate a tuple of this type instead.
113 The translation works by simply putting arguments to first slots that they fit
114 in. Suppose we had
115
116 (# (# 42#, 'c' #) | | #)
117
118 42# fits in Word#, 'c' fits in Any, so we generate this application:
119
120 (# 1#, 'c', 42#, rubbish #)
121
122 Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
123 3# fits in Word #, so we get:
124
125 (# 2#, rubbish, 2#, 3# #).
126
127 Note [Types in StgConApp]
128 ~~~~~~~~~~~~~~~~~~~~~~~~~
129 Suppose we have this unboxed sum term:
130
131 (# 123 | #)
132
133 What will be the unboxed tuple representation? We can't tell without knowing the
134 type of this term. For example, these are all valid tuples for this:
135
136 (# 1#, 123 #) -- when type is (# Int | String #)
137 (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
138 (# 1#, 123, rubbish, rubbish #)
139 -- when type is (# Int | (# Int, Int, Int #) #)
140
141 So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
142 layout to use. Note that unlifted values can't be let-bound, so we don't need
143 types in StgRhsCon.
144
145 Note [UnariseEnv can map to literals]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
148 needs to map variables to literals too. Suppose we have this Core:
149
150 f (# x | #)
151
152 ==> (CorePrep)
153
154 case (# x | #) of y {
155 _ -> f y
156 }
157
158 ==> (MultiVal)
159
160 case (# 1#, x #) of [x1, x2] {
161 _ -> f x1 x2
162 }
163
164 To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
165
166 x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
167
168 so that `f x1 x2` becomes `f 1# x`.
169
170 Note [Unarisation and arity]
171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
172 Because of unarisation, the arity that will be recorded in the generated info
173 table for an Id may be larger than the idArity. Instead we record what we call
174 the RepArity, which is the Arity taking into account any expanded arguments, and
175 corresponds to the number of (possibly-void) *registers* arguments will arrive
176 in.
177 -}
178
179 {-# LANGUAGE CPP, TupleSections #-}
180
181 module UnariseStg (unarise) where
182
183 #include "HsVersions.h"
184
185 import BasicTypes
186 import CoreSyn
187 import DataCon
188 import FastString (FastString, mkFastString)
189 import Id
190 import Literal (Literal (..))
191 import MkId (voidPrimId, voidArgId)
192 import MonadUtils (mapAccumLM)
193 import Outputable
194 import RepType
195 import StgSyn
196 import Type
197 import TysPrim (intPrimTyCon, intPrimTy)
198 import TysWiredIn
199 import UniqSupply
200 import Util
201 import VarEnv
202
203 import Data.Bifunctor (second)
204 import Data.Maybe (mapMaybe)
205 import qualified Data.IntMap as IM
206
207 --------------------------------------------------------------------------------
208
209 -- | A mapping from binders to the Ids they were expanded/renamed to.
210 --
211 -- x :-> MultiVal [a,b,c] in rho
212 --
213 -- iff x's repType is a MultiRep, or equivalently
214 -- x's type is an unboxed tuple, sum or void.
215 --
216 -- x :-> UnaryVal x'
217 --
218 -- iff x's RepType is UnaryRep or equivalently
219 -- x's type is not unboxed tuple, sum or void.
220 --
221 -- So
222 -- x :-> MultiVal [a] in rho
223 -- means x is represented by singleton tuple.
224 --
225 -- x :-> MultiVal [] in rho
226 -- means x is void.
227 --
228 -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
229 -- (i.e. no unboxed tuples, sums or voids)
230 --
231 type UnariseEnv = VarEnv UnariseVal
232
233 data UnariseVal
234 = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
235 | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation].
236
237 instance Outputable UnariseVal where
238 ppr (MultiVal args) = text "MultiVal" <+> ppr args
239 ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg
240
241 -- | Extend the environment, checking the UnariseEnv invariant.
242 extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
243 extendRho rho x (MultiVal args)
244 = ASSERT (all (isNvUnaryType . stgArgType) args)
245 extendVarEnv rho x (MultiVal args)
246 extendRho rho x (UnaryVal val)
247 = ASSERT (isNvUnaryType (stgArgType val))
248 extendVarEnv rho x (UnaryVal val)
249
250 --------------------------------------------------------------------------------
251
252 type OutStgExpr = StgExpr
253 type InId = Id
254 type OutId = Id
255 type InStgAlt = StgAlt
256 type InStgArg = StgArg
257 type OutStgArg = StgArg
258
259 unarise :: UniqSupply -> [StgBinding] -> [StgBinding]
260 unarise us binds = initUs_ us (mapM (unariseBinding emptyVarEnv) binds)
261
262 unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
263 unariseBinding rho (StgNonRec x rhs)
264 = StgNonRec x <$> unariseRhs rho rhs
265 unariseBinding rho (StgRec xrhss)
266 = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
267
268 unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
269 unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr)
270 = do (rho', args1) <- unariseFunArgBinders rho args
271 expr' <- unariseExpr rho' expr
272 let fvs' = unariseFreeVars rho fvs
273 return (StgRhsClosure ccs b_info fvs' update_flag args1 expr')
274
275 unariseRhs rho (StgRhsCon ccs con args)
276 = ASSERT (not (isUnboxedTupleCon con || isUnboxedSumCon con))
277 return (StgRhsCon ccs con (unariseConArgs rho args))
278
279 --------------------------------------------------------------------------------
280
281 unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
282
283 unariseExpr rho e@(StgApp f [])
284 = case lookupVarEnv rho f of
285 Just (MultiVal args) -- Including empty tuples
286 -> return (mkTuple args)
287 Just (UnaryVal (StgVarArg f'))
288 -> return (StgApp f' [])
289 Just (UnaryVal (StgLitArg f'))
290 -> return (StgLit f')
291 Just (UnaryVal arg@(StgRubbishArg {}))
292 -> pprPanic "unariseExpr - app1" (ppr e $$ ppr arg)
293 Nothing
294 -> return e
295
296 unariseExpr rho e@(StgApp f args)
297 = return (StgApp f' (unariseFunArgs rho args))
298 where
299 f' = case lookupVarEnv rho f of
300 Just (UnaryVal (StgVarArg f')) -> f'
301 Nothing -> f
302 err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
303 -- Can't happen because 'args' is non-empty, and
304 -- a tuple or sum cannot be applied to anything
305
306 unariseExpr _ (StgLit l)
307 = return (StgLit l)
308
309 unariseExpr rho (StgConApp dc args ty_args)
310 | Just args' <- unariseMulti_maybe rho dc args ty_args
311 = return (mkTuple args')
312
313 | otherwise
314 , let args' = unariseConArgs rho args
315 = return (StgConApp dc args' (map stgArgType args'))
316
317 unariseExpr rho (StgOpApp op args ty)
318 = return (StgOpApp op (unariseFunArgs rho args) ty)
319
320 unariseExpr _ e@StgLam{}
321 = pprPanic "unariseExpr: found lambda" (ppr e)
322
323 unariseExpr rho (StgCase scrut bndr alt_ty alts)
324 -- a tuple/sum binders in the scrutinee can always be eliminated
325 | StgApp v [] <- scrut
326 , Just (MultiVal xs) <- lookupVarEnv rho v
327 = elimCase rho xs bndr alt_ty alts
328
329 -- Handle strict lets for tuples and sums:
330 -- case (# a,b #) of r -> rhs
331 -- and analogously for sums
332 | StgConApp dc args ty_args <- scrut
333 , Just args' <- unariseMulti_maybe rho dc args ty_args
334 = elimCase rho args' bndr alt_ty alts
335
336 -- general case
337 | otherwise
338 = do scrut' <- unariseExpr rho scrut
339 alts' <- unariseAlts rho alt_ty bndr alts
340 return (StgCase scrut' bndr alt_ty alts')
341 -- bndr will be dead after unarise
342
343 unariseExpr rho (StgLet bind e)
344 = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
345
346 unariseExpr rho (StgLetNoEscape bind e)
347 = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e
348
349 unariseExpr rho (StgTick tick e)
350 = StgTick tick <$> unariseExpr rho e
351
352 -- Doesn't return void args.
353 unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
354 unariseMulti_maybe rho dc args ty_args
355 | isUnboxedTupleCon dc
356 = Just (unariseConArgs rho args)
357
358 | isUnboxedSumCon dc
359 , let args1 = ASSERT (isSingleton args) (unariseConArgs rho args)
360 = Just (mkUbxSum dc ty_args args1)
361
362 | otherwise
363 = Nothing
364
365 --------------------------------------------------------------------------------
366
367 elimCase :: UnariseEnv
368 -> [OutStgArg] -- non-void args
369 -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
370
371 elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
372 = do let rho1 = extendRho rho bndr (MultiVal args)
373 rho2
374 | isUnboxedTupleBndr bndr
375 = mapTupleIdBinders bndrs args rho1
376 | otherwise
377 = ASSERT (isUnboxedSumBndr bndr)
378 if null bndrs then rho1
379 else mapSumIdBinders bndrs args rho1
380
381 unariseExpr rho2 rhs
382
383 elimCase rho args bndr (MultiValAlt _) alts
384 | isUnboxedSumBndr bndr
385 = do let (tag_arg : real_args) = args
386 tag_bndr <- mkId (mkFastString "tag") tagTy
387 -- this won't be used but we need a binder anyway
388 let rho1 = extendRho rho bndr (MultiVal args)
389 scrut' = case tag_arg of
390 StgVarArg v -> StgApp v []
391 StgLitArg l -> StgLit l
392 StgRubbishArg _ -> pprPanic "unariseExpr" (ppr args)
393
394 alts' <- unariseSumAlts rho1 real_args alts
395 return (StgCase scrut' tag_bndr tagAltTy alts')
396
397 elimCase _ args bndr alt_ty alts
398 = pprPanic "elimCase - unhandled case"
399 (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
400
401 --------------------------------------------------------------------------------
402
403 unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
404 unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
405 | isUnboxedTupleBndr bndr
406 = do (rho', ys) <- unariseConArgBinder rho bndr
407 e' <- unariseExpr rho' e
408 return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
409
410 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
411 | isUnboxedTupleBndr bndr
412 = do (rho', ys1) <- unariseConArgBinders rho ys
413 MASSERT(n == length ys1)
414 let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
415 e' <- unariseExpr rho'' e
416 return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
417
418 unariseAlts _ (MultiValAlt _) bndr alts
419 | isUnboxedTupleBndr bndr
420 = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
421
422 -- In this case we don't need to scrutinize the tag bit
423 unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
424 | isUnboxedSumBndr bndr
425 = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
426 rhs' <- unariseExpr rho_sum_bndrs rhs
427 return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
428
429 unariseAlts rho (MultiValAlt _) bndr alts
430 | isUnboxedSumBndr bndr
431 = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
432 alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
433 let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
434 return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
435 scrt_bndrs,
436 inner_case) ]
437
438 unariseAlts rho _ _ alts
439 = mapM (\alt -> unariseAlt rho alt) alts
440
441 unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
442 unariseAlt rho (con, xs, e)
443 = do (rho', xs') <- unariseConArgBinders rho xs
444 (con, xs',) <$> unariseExpr rho' e
445
446 --------------------------------------------------------------------------------
447
448 -- | Make alternatives that match on the tag of a sum
449 -- (i.e. generate LitAlts for the tag)
450 unariseSumAlts :: UnariseEnv
451 -> [StgArg] -- sum components _excluding_ the tag bit.
452 -> [StgAlt] -- original alternative with sum LHS
453 -> UniqSM [StgAlt]
454 unariseSumAlts env args alts
455 = do alts' <- mapM (unariseSumAlt env args) alts
456 return (mkDefaultLitAlt alts')
457
458 unariseSumAlt :: UnariseEnv
459 -> [StgArg] -- sum components _excluding_ the tag bit.
460 -> StgAlt -- original alternative with sum LHS
461 -> UniqSM StgAlt
462 unariseSumAlt rho _ (DEFAULT, _, e)
463 = ( DEFAULT, [], ) <$> unariseExpr rho e
464
465 unariseSumAlt rho args (DataAlt sumCon, bs, e)
466 = do let rho' = mapSumIdBinders bs args rho
467 e' <- unariseExpr rho' e
468 return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
469
470 unariseSumAlt _ scrt alt
471 = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
472
473 --------------------------------------------------------------------------------
474
475 mapTupleIdBinders
476 :: [InId] -- Un-processed binders of a tuple alternative.
477 -- Can have void binders.
478 -> [OutStgArg] -- Arguments that form the tuple (after unarisation).
479 -- Can't have void args.
480 -> UnariseEnv
481 -> UnariseEnv
482 mapTupleIdBinders ids args0 rho0
483 = ASSERT (not (any (isVoidTy . stgArgType) args0))
484 let
485 ids_unarised :: [(Id, RepType)]
486 ids_unarised = map (\id -> (id, repType (idType id))) ids
487
488 map_ids :: UnariseEnv -> [(Id, RepType)] -> [StgArg] -> UnariseEnv
489 map_ids rho [] _ = rho
490 map_ids rho ((x, x_rep) : xs) args =
491 let
492 x_arity = length (repTypeSlots x_rep)
493 (x_args, args') =
494 ASSERT(args `lengthAtLeast` x_arity)
495 splitAt x_arity args
496
497 rho'
498 | isMultiRep x_rep
499 = extendRho rho x (MultiVal x_args)
500 | otherwise
501 = ASSERT (x_args `lengthIs` 1)
502 extendRho rho x (UnaryVal (head x_args))
503 in
504 map_ids rho' xs args'
505 in
506 map_ids rho0 ids_unarised args0
507
508 mapSumIdBinders
509 :: [InId] -- Binder of a sum alternative (remember that sum patterns
510 -- only have one binder, so this list should be a singleton)
511 -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
512 -- Can't have void args.
513 -> UnariseEnv
514 -> UnariseEnv
515
516 mapSumIdBinders [id] args rho0
517 = ASSERT (not (any (isVoidTy . stgArgType) args))
518 let
519 arg_slots = concatMap (repTypeSlots . repType . stgArgType) args
520 id_slots = repTypeSlots (repType (idType id))
521 layout1 = layout arg_slots id_slots
522 in
523 if isMultiValBndr id
524 then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
525 else ASSERT(layout1 `lengthIs` 1)
526 extendRho rho0 id (UnaryVal (args !! head layout1))
527
528 mapSumIdBinders ids sum_args _
529 = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
530
531 -- | Build a unboxed sum term from arguments of an alternative.
532 --
533 -- Example, for (# x | #) :: (# (# #) | Int #) we call
534 --
535 -- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
536 --
537 -- which returns
538 --
539 -- [ 1#, rubbish ]
540 --
541 mkUbxSum
542 :: DataCon -- Sum data con
543 -> [Type] -- Type arguments of the sum data con
544 -> [OutStgArg] -- Actual arguments of the alternative.
545 -> [OutStgArg] -- Final tuple arguments
546 mkUbxSum dc ty_args args0
547 = let
548 (_ : sum_slots) = ubxSumRepType ty_args
549 -- drop tag slot
550
551 tag = dataConTag dc
552
553 layout' = layout sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
554 tag_arg = StgLitArg (MachInt (fromIntegral tag))
555 arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
556
557 mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
558 mkTupArgs _ [] _
559 = []
560 mkTupArgs arg_idx (slot : slots_left) arg_map
561 | Just stg_arg <- IM.lookup arg_idx arg_map
562 = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
563 | otherwise
564 = StgRubbishArg (slotTyToType slot) : mkTupArgs (arg_idx + 1) slots_left arg_map
565 in
566 tag_arg : mkTupArgs 0 sum_slots arg_idxs
567
568 --------------------------------------------------------------------------------
569
570 {-
571 For arguments (StgArg) and binders (Id) we have two kind of unarisation:
572
573 - When unarising function arg binders and arguments, we don't want to remove
574 void binders and arguments. For example,
575
576 f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
577 f x y z = <body>
578
579 Here after unarise we should still get a function with arity 3. Similarly
580 in the call site we shouldn't remove void arguments:
581
582 f (# (# #), (# #) #) voidId rw
583
584 When unarising <body>, we extend the environment with these binders:
585
586 x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
587
588 Because their rep types are `MultiRep []` (aka. void). This means that when
589 we see `x` in a function argument position, we actually replace it with a
590 void argument. When we see it in a DataCon argument position, we just get
591 rid of it, because DataCon applications in STG are always saturated.
592
593 - When unarising case alternative binders we remove void binders, but we
594 still update the environment the same way, because those binders may be
595 used in the RHS. Example:
596
597 case x of y {
598 (# x1, x2, x3 #) -> <RHS>
599 }
600
601 We know that y can't be void, because we don't scrutinize voids, so x will
602 be unarised to some number of arguments, and those arguments will have at
603 least one non-void thing. So in the rho we will have something like:
604
605 x :-> MultiVal [xu1, xu2]
606
607 Now, after we eliminate void binders in the pattern, we get exactly the same
608 number of binders, and extend rho again with these:
609
610 x1 :-> UnaryVal xu1
611 x2 :-> MultiVal [] -- x2 is void
612 x3 :-> UnaryVal xu2
613
614 Now when we see x2 in a function argument position or in return position, we
615 generate void#. In constructor argument position, we just remove it.
616
617 So in short, when we have a void id,
618
619 - We keep it if it's a lambda argument binder or
620 in argument position of an application.
621
622 - We remove it if it's a DataCon field binder or
623 in argument position of a DataCon application.
624 -}
625
626 --------------------------------------------------------------------------------
627
628 -- | MultiVal a function argument. Never returns an empty list.
629 unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
630 unariseFunArg rho (StgVarArg x) =
631 case lookupVarEnv rho x of
632 Just (MultiVal []) -> [voidArg] -- NB: do not remove void args
633 Just (MultiVal as) -> as
634 Just (UnaryVal arg) -> [arg]
635 Nothing -> [StgVarArg x]
636 unariseFunArg _ arg = [arg]
637
638 unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
639 unariseFunArgs = concatMap . unariseFunArg
640
641 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
642 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
643
644 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
645 -- Result list of binders is never empty
646 unariseFunArgBinder rho x =
647 case repType (idType x) of
648 UnaryRep _ -> return (rho, [x])
649 MultiRep [] -> return (extendRho rho x (MultiVal []), [voidArgId])
650 -- NB: do not remove void binders
651 MultiRep slots -> do
652 xs <- mkIds (mkFastString "us") (map slotTyToType slots)
653 return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
654
655 --------------------------------------------------------------------------------
656
657 -- | MultiVal a DataCon argument. Returns an empty list when argument is void.
658 unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
659 unariseConArg rho (StgVarArg x) =
660 case lookupVarEnv rho x of
661 Just (UnaryVal arg) -> [arg]
662 Just (MultiVal as) -> as -- 'as' can be empty
663 Nothing
664 | isVoidTy (idType x) -> [] -- e.g. C realWorld#
665 -- Here realWorld# is not in the envt, but
666 -- is a void, and so should be eliminated
667 | otherwise -> [StgVarArg x]
668 unariseConArg _ arg = [arg] -- We have no void literals
669
670 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
671 unariseConArgs = concatMap . unariseConArg
672
673 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
674 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
675
676 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
677 unariseConArgBinder rho x =
678 case repType (idType x) of
679 UnaryRep _ -> return (rho, [x])
680 MultiRep slots -> do
681 xs <- mkIds (mkFastString "us") (map slotTyToType slots)
682 return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
683
684 unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
685 unariseFreeVars rho fvs
686 = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]
687 -- Notice that we filter out any StgLitArgs
688 -- e.g. case e of (x :: (# Int | Bool #))
689 -- (# v | #) -> ... let {g = \y. ..x...} in ...
690 -- (# | w #) -> ...
691 -- Here 'x' is free in g's closure, and the env will have
692 -- x :-> [1, v]
693 -- we want to capture 'v', but not 1, in the free vars
694
695 unariseFreeVar :: UnariseEnv -> Id -> [StgArg]
696 unariseFreeVar rho x =
697 case lookupVarEnv rho x of
698 Just (MultiVal args) -> args
699 Just (UnaryVal arg) -> [arg]
700 Nothing -> [StgVarArg x]
701
702 --------------------------------------------------------------------------------
703
704 mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
705 mkIds fs tys = mapM (mkId fs) tys
706
707 mkId :: FastString -> UnaryType -> UniqSM Id
708 mkId = mkSysLocalOrCoVarM
709
710 isMultiValBndr :: Id -> Bool
711 isMultiValBndr = isMultiRep . repType . idType
712
713 isUnboxedSumBndr :: Id -> Bool
714 isUnboxedSumBndr = isUnboxedSumType . idType
715
716 isUnboxedTupleBndr :: Id -> Bool
717 isUnboxedTupleBndr = isUnboxedTupleType . idType
718
719 mkTuple :: [StgArg] -> StgExpr
720 mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
721
722 tagAltTy :: AltType
723 tagAltTy = PrimAlt intPrimTyCon
724
725 tagTy :: Type
726 tagTy = intPrimTy
727
728 voidArg :: StgArg
729 voidArg = StgVarArg voidPrimId
730
731 mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
732 -- We have an exhauseive list of literal alternatives
733 -- 1# -> e1
734 -- 2# -> e2
735 -- Since they are exhaustive, we can replace one with DEFAULT, to avoid
736 -- generating a final test. Remember, the DEFAULT comes first if it exists.
737 mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
738 mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
739 mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
740 mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)