bcf699b369b9435e35a64dbeefb56999dc9f0080
[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 Note [Post-unarisation invariants]
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 STG programs after unarisation have these invariants:
181
182 * No unboxed sums at all.
183
184 * No unboxed tuple binders. Tuples only appear in return position.
185
186 * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
187 This means that it's safe to wrap `StgArg`s of DataCon applications with
188 `StgCmmEnv.NonVoid`, for example.
189
190 * Alt binders (binders in patterns) are always non-void.
191 -}
192
193 {-# LANGUAGE CPP, TupleSections #-}
194
195 module UnariseStg (unarise) where
196
197 #include "HsVersions.h"
198
199 import GhcPrelude
200
201 import BasicTypes
202 import CoreSyn
203 import DataCon
204 import FastString (FastString, mkFastString)
205 import Id
206 import Literal (Literal (..), literalType)
207 import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
208 import MkId (voidPrimId, voidArgId)
209 import MonadUtils (mapAccumLM)
210 import Outputable
211 import RepType
212 import StgSyn
213 import Type
214 import TysPrim (intPrimTy)
215 import TysWiredIn
216 import UniqSupply
217 import Util
218 import VarEnv
219
220 import Data.Bifunctor (second)
221 import Data.Maybe (mapMaybe)
222 import qualified Data.IntMap as IM
223
224 --------------------------------------------------------------------------------
225
226 -- | A mapping from binders to the Ids they were expanded/renamed to.
227 --
228 -- x :-> MultiVal [a,b,c] in rho
229 --
230 -- iff x's typePrimRep is not a singleton, or equivalently
231 -- x's type is an unboxed tuple, sum or void.
232 --
233 -- x :-> UnaryVal x'
234 --
235 -- iff x's RepType is UnaryRep or equivalently
236 -- x's type is not unboxed tuple, sum or void.
237 --
238 -- So
239 -- x :-> MultiVal [a] in rho
240 -- means x is represented by singleton tuple.
241 --
242 -- x :-> MultiVal [] in rho
243 -- means x is void.
244 --
245 -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
246 -- (i.e. no unboxed tuples, sums or voids)
247 --
248 type UnariseEnv = VarEnv UnariseVal
249
250 data UnariseVal
251 = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
252 | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation].
253
254 instance Outputable UnariseVal where
255 ppr (MultiVal args) = text "MultiVal" <+> ppr args
256 ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg
257
258 -- | Extend the environment, checking the UnariseEnv invariant.
259 extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
260 extendRho rho x (MultiVal args)
261 = ASSERT(all (isNvUnaryType . stgArgType) args)
262 extendVarEnv rho x (MultiVal args)
263 extendRho rho x (UnaryVal val)
264 = ASSERT(isNvUnaryType (stgArgType val))
265 extendVarEnv rho x (UnaryVal val)
266
267 --------------------------------------------------------------------------------
268
269 unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
270 unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
271
272 unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
273 unariseTopBinding rho (StgTopLifted bind)
274 = StgTopLifted <$> unariseBinding rho bind
275 unariseTopBinding _ bind@StgTopStringLit{} = return bind
276
277 unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
278 unariseBinding rho (StgNonRec x rhs)
279 = StgNonRec x <$> unariseRhs rho rhs
280 unariseBinding rho (StgRec xrhss)
281 = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
282
283 unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
284 unariseRhs rho (StgRhsClosure ccs b_info fvs update_flag args expr)
285 = do (rho', args1) <- unariseFunArgBinders rho args
286 expr' <- unariseExpr rho' expr
287 let fvs' = unariseFreeVars rho fvs
288 return (StgRhsClosure ccs b_info fvs' update_flag args1 expr')
289
290 unariseRhs rho (StgRhsCon ccs con args)
291 = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
292 return (StgRhsCon ccs con (unariseConArgs rho args))
293
294 --------------------------------------------------------------------------------
295
296 unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
297
298 unariseExpr rho e@(StgApp f [])
299 = case lookupVarEnv rho f of
300 Just (MultiVal args) -- Including empty tuples
301 -> return (mkTuple args)
302 Just (UnaryVal (StgVarArg f'))
303 -> return (StgApp f' [])
304 Just (UnaryVal (StgLitArg f'))
305 -> return (StgLit f')
306 Nothing
307 -> return e
308
309 unariseExpr rho e@(StgApp f args)
310 = return (StgApp f' (unariseFunArgs rho args))
311 where
312 f' = case lookupVarEnv rho f of
313 Just (UnaryVal (StgVarArg f')) -> f'
314 Nothing -> f
315 err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
316 -- Can't happen because 'args' is non-empty, and
317 -- a tuple or sum cannot be applied to anything
318
319 unariseExpr _ (StgLit l)
320 = return (StgLit l)
321
322 unariseExpr rho (StgConApp dc args ty_args)
323 | Just args' <- unariseMulti_maybe rho dc args ty_args
324 = return (mkTuple args')
325
326 | otherwise
327 , let args' = unariseConArgs rho args
328 = return (StgConApp dc args' (map stgArgType args'))
329
330 unariseExpr rho (StgOpApp op args ty)
331 = return (StgOpApp op (unariseFunArgs rho args) ty)
332
333 unariseExpr _ e@StgLam{}
334 = pprPanic "unariseExpr: found lambda" (ppr e)
335
336 unariseExpr rho (StgCase scrut bndr alt_ty alts)
337 -- tuple/sum binders in the scrutinee can always be eliminated
338 | StgApp v [] <- scrut
339 , Just (MultiVal xs) <- lookupVarEnv rho v
340 = elimCase rho xs bndr alt_ty alts
341
342 -- Handle strict lets for tuples and sums:
343 -- case (# a,b #) of r -> rhs
344 -- and analogously for sums
345 | StgConApp dc args ty_args <- scrut
346 , Just args' <- unariseMulti_maybe rho dc args ty_args
347 = elimCase rho args' bndr alt_ty alts
348
349 -- general case
350 | otherwise
351 = do scrut' <- unariseExpr rho scrut
352 alts' <- unariseAlts rho alt_ty bndr alts
353 return (StgCase scrut' bndr alt_ty alts')
354 -- bndr may have a unboxed sum/tuple type but it will be
355 -- dead after unarise (checked in StgLint)
356
357 unariseExpr rho (StgLet bind e)
358 = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
359
360 unariseExpr rho (StgLetNoEscape bind e)
361 = StgLetNoEscape <$> unariseBinding rho bind <*> unariseExpr rho e
362
363 unariseExpr rho (StgTick tick e)
364 = StgTick tick <$> unariseExpr rho e
365
366 -- Doesn't return void args.
367 unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
368 unariseMulti_maybe rho dc args ty_args
369 | isUnboxedTupleCon dc
370 = Just (unariseConArgs rho args)
371
372 | isUnboxedSumCon dc
373 , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
374 = Just (mkUbxSum dc ty_args args1)
375
376 | otherwise
377 = Nothing
378
379 --------------------------------------------------------------------------------
380
381 elimCase :: UnariseEnv
382 -> [OutStgArg] -- non-void args
383 -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
384
385 elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
386 = do let rho1 = extendRho rho bndr (MultiVal args)
387 rho2
388 | isUnboxedTupleBndr bndr
389 = mapTupleIdBinders bndrs args rho1
390 | otherwise
391 = ASSERT(isUnboxedSumBndr bndr)
392 if null bndrs then rho1
393 else mapSumIdBinders bndrs args rho1
394
395 unariseExpr rho2 rhs
396
397 elimCase rho args bndr (MultiValAlt _) alts
398 | isUnboxedSumBndr bndr
399 = do let (tag_arg : real_args) = args
400 tag_bndr <- mkId (mkFastString "tag") tagTy
401 -- this won't be used but we need a binder anyway
402 let rho1 = extendRho rho bndr (MultiVal args)
403 scrut' = case tag_arg of
404 StgVarArg v -> StgApp v []
405 StgLitArg l -> StgLit l
406
407 alts' <- unariseSumAlts rho1 real_args alts
408 return (StgCase scrut' tag_bndr tagAltTy alts')
409
410 elimCase _ args bndr alt_ty alts
411 = pprPanic "elimCase - unhandled case"
412 (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
413
414 --------------------------------------------------------------------------------
415
416 unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
417 unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
418 | isUnboxedTupleBndr bndr
419 = do (rho', ys) <- unariseConArgBinder rho bndr
420 e' <- unariseExpr rho' e
421 return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
422
423 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
424 | isUnboxedTupleBndr bndr
425 = do (rho', ys1) <- unariseConArgBinders rho ys
426 MASSERT(ys1 `lengthIs` n)
427 let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
428 e' <- unariseExpr rho'' e
429 return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
430
431 unariseAlts _ (MultiValAlt _) bndr alts
432 | isUnboxedTupleBndr bndr
433 = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
434
435 -- In this case we don't need to scrutinize the tag bit
436 unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
437 | isUnboxedSumBndr bndr
438 = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
439 rhs' <- unariseExpr rho_sum_bndrs rhs
440 return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
441
442 unariseAlts rho (MultiValAlt _) bndr alts
443 | isUnboxedSumBndr bndr
444 = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
445 alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
446 let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
447 return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
448 scrt_bndrs,
449 inner_case) ]
450
451 unariseAlts rho _ _ alts
452 = mapM (\alt -> unariseAlt rho alt) alts
453
454 unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
455 unariseAlt rho (con, xs, e)
456 = do (rho', xs') <- unariseConArgBinders rho xs
457 (con, xs',) <$> unariseExpr rho' e
458
459 --------------------------------------------------------------------------------
460
461 -- | Make alternatives that match on the tag of a sum
462 -- (i.e. generate LitAlts for the tag)
463 unariseSumAlts :: UnariseEnv
464 -> [StgArg] -- sum components _excluding_ the tag bit.
465 -> [StgAlt] -- original alternative with sum LHS
466 -> UniqSM [StgAlt]
467 unariseSumAlts env args alts
468 = do alts' <- mapM (unariseSumAlt env args) alts
469 return (mkDefaultLitAlt alts')
470
471 unariseSumAlt :: UnariseEnv
472 -> [StgArg] -- sum components _excluding_ the tag bit.
473 -> StgAlt -- original alternative with sum LHS
474 -> UniqSM StgAlt
475 unariseSumAlt rho _ (DEFAULT, _, e)
476 = ( DEFAULT, [], ) <$> unariseExpr rho e
477
478 unariseSumAlt rho args (DataAlt sumCon, bs, e)
479 = do let rho' = mapSumIdBinders bs args rho
480 e' <- unariseExpr rho' e
481 return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
482
483 unariseSumAlt _ scrt alt
484 = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
485
486 --------------------------------------------------------------------------------
487
488 mapTupleIdBinders
489 :: [InId] -- Un-processed binders of a tuple alternative.
490 -- Can have void binders.
491 -> [OutStgArg] -- Arguments that form the tuple (after unarisation).
492 -- Can't have void args.
493 -> UnariseEnv
494 -> UnariseEnv
495 mapTupleIdBinders ids args0 rho0
496 = ASSERT(not (any (isVoidTy . stgArgType) args0))
497 let
498 ids_unarised :: [(Id, [PrimRep])]
499 ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
500
501 map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
502 map_ids rho [] _ = rho
503 map_ids rho ((x, x_reps) : xs) args =
504 let
505 x_arity = length x_reps
506 (x_args, args') =
507 ASSERT(args `lengthAtLeast` x_arity)
508 splitAt x_arity args
509
510 rho'
511 | x_arity == 1
512 = ASSERT(x_args `lengthIs` 1)
513 extendRho rho x (UnaryVal (head x_args))
514 | otherwise
515 = extendRho rho x (MultiVal x_args)
516 in
517 map_ids rho' xs args'
518 in
519 map_ids rho0 ids_unarised args0
520
521 mapSumIdBinders
522 :: [InId] -- Binder of a sum alternative (remember that sum patterns
523 -- only have one binder, so this list should be a singleton)
524 -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
525 -- Can't have void args.
526 -> UnariseEnv
527 -> UnariseEnv
528
529 mapSumIdBinders [id] args rho0
530 = ASSERT(not (any (isVoidTy . stgArgType) args))
531 let
532 arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
533 id_slots = map primRepSlot $ typePrimRep (idType id)
534 layout1 = layoutUbxSum arg_slots id_slots
535 in
536 if isMultiValBndr id
537 then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
538 else ASSERT(layout1 `lengthIs` 1)
539 extendRho rho0 id (UnaryVal (args !! head layout1))
540
541 mapSumIdBinders ids sum_args _
542 = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
543
544 -- | Build a unboxed sum term from arguments of an alternative.
545 --
546 -- Example, for (# x | #) :: (# (# #) | Int #) we call
547 --
548 -- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
549 --
550 -- which returns
551 --
552 -- [ 1#, rubbish ]
553 --
554 mkUbxSum
555 :: DataCon -- Sum data con
556 -> [Type] -- Type arguments of the sum data con
557 -> [OutStgArg] -- Actual arguments of the alternative.
558 -> [OutStgArg] -- Final tuple arguments
559 mkUbxSum dc ty_args args0
560 = let
561 (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
562 -- drop tag slot
563
564 tag = dataConTag dc
565
566 layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
567 tag_arg = StgLitArg (MachInt (fromIntegral tag))
568 arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
569
570 mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
571 mkTupArgs _ [] _
572 = []
573 mkTupArgs arg_idx (slot : slots_left) arg_map
574 | Just stg_arg <- IM.lookup arg_idx arg_map
575 = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
576 | otherwise
577 = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
578
579 slotRubbishArg :: SlotTy -> StgArg
580 slotRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
581 -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
582 slotRubbishArg WordSlot = StgLitArg (MachWord 0)
583 slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
584 slotRubbishArg FloatSlot = StgLitArg (MachFloat 0)
585 slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
586 in
587 tag_arg : mkTupArgs 0 sum_slots arg_idxs
588
589 --------------------------------------------------------------------------------
590
591 {-
592 For arguments (StgArg) and binders (Id) we have two kind of unarisation:
593
594 - When unarising function arg binders and arguments, we don't want to remove
595 void binders and arguments. For example,
596
597 f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
598 f x y z = <body>
599
600 Here after unarise we should still get a function with arity 3. Similarly
601 in the call site we shouldn't remove void arguments:
602
603 f (# (# #), (# #) #) voidId rw
604
605 When unarising <body>, we extend the environment with these binders:
606
607 x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
608
609 Because their rep types are `MultiRep []` (aka. void). This means that when
610 we see `x` in a function argument position, we actually replace it with a
611 void argument. When we see it in a DataCon argument position, we just get
612 rid of it, because DataCon applications in STG are always saturated.
613
614 - When unarising case alternative binders we remove void binders, but we
615 still update the environment the same way, because those binders may be
616 used in the RHS. Example:
617
618 case x of y {
619 (# x1, x2, x3 #) -> <RHS>
620 }
621
622 We know that y can't be void, because we don't scrutinize voids, so x will
623 be unarised to some number of arguments, and those arguments will have at
624 least one non-void thing. So in the rho we will have something like:
625
626 x :-> MultiVal [xu1, xu2]
627
628 Now, after we eliminate void binders in the pattern, we get exactly the same
629 number of binders, and extend rho again with these:
630
631 x1 :-> UnaryVal xu1
632 x2 :-> MultiVal [] -- x2 is void
633 x3 :-> UnaryVal xu2
634
635 Now when we see x2 in a function argument position or in return position, we
636 generate void#. In constructor argument position, we just remove it.
637
638 So in short, when we have a void id,
639
640 - We keep it if it's a lambda argument binder or
641 in argument position of an application.
642
643 - We remove it if it's a DataCon field binder or
644 in argument position of a DataCon application.
645 -}
646
647 unariseArgBinder
648 :: Bool -- data con arg?
649 -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
650 unariseArgBinder is_con_arg rho x =
651 case typePrimRep (idType x) of
652 []
653 | is_con_arg
654 -> return (extendRho rho x (MultiVal []), [])
655 | otherwise -- fun arg, do not remove void binders
656 -> return (extendRho rho x (MultiVal []), [voidArgId])
657
658 [rep]
659 -- Arg represented as single variable, but original type may still be an
660 -- unboxed sum/tuple, e.g. (# Void# | Void# #).
661 --
662 -- While not unarising the binder in this case does not break any programs
663 -- (because it unarises to a single variable), it triggers StgLint as we
664 -- break the the post-unarisation invariant that says unboxed tuple/sum
665 -- binders should vanish. See Note [Post-unarisation invariants].
666 | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
667 -> do x' <- mkId (mkFastString "us") (primRepToType rep)
668 return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
669 | otherwise
670 -> return (rho, [x])
671
672 reps -> do
673 xs <- mkIds (mkFastString "us") (map primRepToType reps)
674 return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
675
676 --------------------------------------------------------------------------------
677
678 -- | MultiVal a function argument. Never returns an empty list.
679 unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
680 unariseFunArg rho (StgVarArg x) =
681 case lookupVarEnv rho x of
682 Just (MultiVal []) -> [voidArg] -- NB: do not remove void args
683 Just (MultiVal as) -> as
684 Just (UnaryVal arg) -> [arg]
685 Nothing -> [StgVarArg x]
686 unariseFunArg _ arg = [arg]
687
688 unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
689 unariseFunArgs = concatMap . unariseFunArg
690
691 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
692 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
693
694 -- Result list of binders is never empty
695 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
696 unariseFunArgBinder = unariseArgBinder False
697
698 --------------------------------------------------------------------------------
699
700 -- | MultiVal a DataCon argument. Returns an empty list when argument is void.
701 unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
702 unariseConArg rho (StgVarArg x) =
703 case lookupVarEnv rho x of
704 Just (UnaryVal arg) -> [arg]
705 Just (MultiVal as) -> as -- 'as' can be empty
706 Nothing
707 | isVoidTy (idType x) -> [] -- e.g. C realWorld#
708 -- Here realWorld# is not in the envt, but
709 -- is a void, and so should be eliminated
710 | otherwise -> [StgVarArg x]
711 unariseConArg _ arg@(StgLitArg lit) =
712 ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals
713 [arg]
714
715 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
716 unariseConArgs = concatMap . unariseConArg
717
718 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
719 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
720
721 -- Different from `unariseFunArgBinder`: result list of binders may be empty.
722 -- See DataCon applications case in Note [Post-unarisation invariants].
723 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
724 unariseConArgBinder = unariseArgBinder True
725
726 unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
727 unariseFreeVars rho fvs
728 = [ v | fv <- fvs, StgVarArg v <- unariseFreeVar rho fv ]
729 -- Notice that we filter out any StgLitArgs
730 -- e.g. case e of (x :: (# Int | Bool #))
731 -- (# v | #) -> ... let {g = \y. ..x...} in ...
732 -- (# | w #) -> ...
733 -- Here 'x' is free in g's closure, and the env will have
734 -- x :-> [1, v]
735 -- we want to capture 'v', but not 1, in the free vars
736
737 unariseFreeVar :: UnariseEnv -> Id -> [StgArg]
738 unariseFreeVar rho x =
739 case lookupVarEnv rho x of
740 Just (MultiVal args) -> args
741 Just (UnaryVal arg) -> [arg]
742 Nothing -> [StgVarArg x]
743
744 --------------------------------------------------------------------------------
745
746 mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
747 mkIds fs tys = mapM (mkId fs) tys
748
749 mkId :: FastString -> UnaryType -> UniqSM Id
750 mkId = mkSysLocalOrCoVarM
751
752 isMultiValBndr :: Id -> Bool
753 isMultiValBndr id
754 | [_] <- typePrimRep (idType id)
755 = False
756 | otherwise
757 = True
758
759 isUnboxedSumBndr :: Id -> Bool
760 isUnboxedSumBndr = isUnboxedSumType . idType
761
762 isUnboxedTupleBndr :: Id -> Bool
763 isUnboxedTupleBndr = isUnboxedTupleType . idType
764
765 mkTuple :: [StgArg] -> StgExpr
766 mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
767
768 tagAltTy :: AltType
769 tagAltTy = PrimAlt IntRep
770
771 tagTy :: Type
772 tagTy = intPrimTy
773
774 voidArg :: StgArg
775 voidArg = StgVarArg voidPrimId
776
777 mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
778 -- We have an exhauseive list of literal alternatives
779 -- 1# -> e1
780 -- 2# -> e2
781 -- Since they are exhaustive, we can replace one with DEFAULT, to avoid
782 -- generating a final test. Remember, the DEFAULT comes first if it exists.
783 mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
784 mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
785 mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
786 mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)