never executed always true always false
1
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE TupleSections #-}
4
5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
6
7 {-
8 (c) The GRASP/AQUA Project, Glasgow University, 1992-2012
9
10 Note [Unarisation]
11 ~~~~~~~~~~~~~~~~~~
12 The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
13 binders. So for example:
14
15 f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
16
17 ==>
18
19 f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
20
21 It is important that we do this at the STG level and NOT at the Core level
22 because it would be very hard to make this pass Core-type-preserving. In this
23 example the type of 'f' changes, for example.
24
25 STG fed to the code generators *must* be unarised because the code generators do
26 not support unboxed tuple and unboxed sum binders natively.
27
28 In more detail: (see next note for unboxed sums)
29
30 Suppose that a variable x : (# t1, t2 #).
31
32 * At the binding site for x, make up fresh vars x1:t1, x2:t2
33
34 * Extend the UnariseEnv x :-> MultiVal [x1,x2]
35
36 * Replace the binding with a curried binding for x1,x2
37
38 Lambda: \x.e ==> \x1 x2. e
39 Case alt: MkT a b x c d -> e ==> MkT a b x1 x2 c d -> e
40
41 * Replace argument occurrences with a sequence of args via a lookup in
42 UnariseEnv
43
44 f a b x c d ==> f a b x1 x2 c d
45
46 * Replace tail-call occurrences with an unboxed tuple via a lookup in
47 UnariseEnv
48
49 x ==> (# x1, x2 #)
50
51 So, for example
52
53 f x = x ==> f x1 x2 = (# x1, x2 #)
54
55 * We /always/ eliminate a case expression when
56
57 - It scrutinises an unboxed tuple or unboxed sum
58
59 - The scrutinee is a variable (or when it is an explicit tuple, but the
60 simplifier eliminates those)
61
62 The case alternative (there can be only one) can be one of these two
63 things:
64
65 - An unboxed tuple pattern. e.g.
66
67 case v of x { (# x1, x2, x3 #) -> ... }
68
69 Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
70 environment with
71
72 x :-> MultiVal [t1,t2,t3]
73 x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
74
75 - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
76
77 By the end of this pass, we only have unboxed tuples in return positions.
78 Unboxed sums are completely eliminated, see next note.
79
80 Note [Translating unboxed sums to unboxed tuples]
81 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
82 Unarise also eliminates unboxed sum binders, and translates unboxed sums in
83 return positions to unboxed tuples. We want to overlap fields of a sum when
84 translating it to a tuple to have efficient memory layout. When translating a
85 sum pattern to a tuple pattern, we need to translate it so that binders of sum
86 alternatives will be mapped to right arguments after the term translation. So
87 translation of sum DataCon applications to tuple DataCon applications and
88 translation of sum patterns to tuple patterns need to be in sync.
89
90 These translations work like this. Suppose we have
91
92 (# x1 | | ... #) :: (# t1 | t2 | ... #)
93
94 remember that t1, t2 ... can be sums and tuples too. So we first generate
95 layouts of those. Then we "merge" layouts of each alternative, which gives us a
96 sum layout with best overlapping possible.
97
98 Layout of a flat type 'ty1' is just [ty1].
99 Layout of a tuple is just concatenation of layouts of its fields.
100
101 For layout of a sum type,
102
103 - We first get layouts of all alternatives.
104 - We sort these layouts based on their "slot types".
105 - We merge all the alternatives.
106
107 For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
108
109 - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]
110 - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]
111 - Merge all alternatives together: [ LiftedPtr, Word, Word ]
112
113 We add a slot for the tag to the first position. So our tuple type is
114
115 (# Tag#, Any, Word#, Word# #)
116 (we use Any for pointer slots)
117
118 Now, any term of this sum type needs to generate a tuple of this type instead.
119 The translation works by simply putting arguments to first slots that they fit
120 in. Suppose we had
121
122 (# (# 42#, 'c' #) | | #)
123
124 42# fits in Word#, 'c' fits in Any, so we generate this application:
125
126 (# 1#, 'c', 42#, rubbish #)
127
128 Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
129 3# fits in Word #, so we get:
130
131 (# 2#, rubbish, 2#, 3# #).
132
133
134 Note [Don't merge lifted and unlifted slots]
135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
136 When merging slots, one might be tempted to collapse lifted and unlifted
137 pointers. However, as seen in #19645, this is wrong. Imagine that you have
138 the program:
139
140 test :: (# Char | ByteArray# #) -> ByteArray#
141 test (# c | #) = doSomething c
142 test (# | ba #) = ba
143
144 Collapsing the Char and ByteArray# slots would produce STG like:
145
146 test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#
147 = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]
148 case tag of tag'
149 1# -> doSomething slot0
150 2# -> slot0;
151
152 Note how `slot0` has a lifted type, despite being bound to an unlifted
153 ByteArray# in the 2# alternative. This liftedness would cause the code generator to
154 attempt to enter it upon returning. As unlifted objects do not have entry code,
155 this causes a runtime crash.
156
157 For this reason, Unarise treats unlifted and lifted things as distinct slot
158 types, despite both being GC pointers. This approach is a slight pessimisation
159 (since we need to pass more arguments) but appears to be the simplest way to
160 avoid #19645. Other alternatives considered include:
161
162 a. Giving unlifted objects "trivial" entry code. However, we ultimately
163 concluded that the value of the "unlifted things are never entered" invariant
164 outweighed the simplicity of this approach.
165
166 b. Annotating occurrences with calling convention information instead of
167 relying on the binder's type. This seemed like a very complicated
168 way to fix what is ultimately a corner-case.
169
170
171 Note [Types in StgConApp]
172 ~~~~~~~~~~~~~~~~~~~~~~~~~
173 Suppose we have this unboxed sum term:
174
175 (# 123 | #)
176
177 What will be the unboxed tuple representation? We can't tell without knowing the
178 type of this term. For example, these are all valid tuples for this:
179
180 (# 1#, 123 #) -- when type is (# Int | String #)
181 (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
182 (# 1#, 123, rubbish, rubbish #)
183 -- when type is (# Int | (# Int, Int, Int #) #)
184
185 So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
186 layout to use. Note that unlifted values can't be let-bound, so we don't need
187 types in StgRhsCon.
188
189 Note [UnariseEnv can map to literals]
190 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
191 To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
192 needs to map variables to literals too. Suppose we have this Core:
193
194 f (# x | #)
195
196 ==> (CorePrep)
197
198 case (# x | #) of y {
199 _ -> f y
200 }
201
202 ==> (MultiVal)
203
204 case (# 1#, x #) of [x1, x2] {
205 _ -> f x1 x2
206 }
207
208 To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
209
210 x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
211
212 so that `f x1 x2` becomes `f 1# x`.
213
214 Note [Unarisation and arity]
215 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
216 Because of unarisation, the arity that will be recorded in the generated info
217 table for an Id may be larger than the idArity. Instead we record what we call
218 the RepArity, which is the Arity taking into account any expanded arguments, and
219 corresponds to the number of (possibly-void) *registers* arguments will arrive
220 in.
221
222 Note [Post-unarisation invariants]
223 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
224 STG programs after unarisation have these invariants:
225
226 * No unboxed sums at all.
227
228 * No unboxed tuple binders. Tuples only appear in return position.
229
230 * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
231 This means that it's safe to wrap `StgArg`s of DataCon applications with
232 `GHC.StgToCmm.Env.NonVoid`, for example.
233
234 * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only
235 appear in return position.
236
237 * Alt binders (binders in patterns) are always non-void.
238
239 * Binders always have zero (for void arguments) or one PrimRep.
240 -}
241
242 module GHC.Stg.Unarise (unarise) where
243
244 import GHC.Prelude
245
246 import GHC.Types.Basic
247 import GHC.Core
248 import GHC.Core.DataCon
249 import GHC.Core.TyCon ( isVoidRep )
250 import GHC.Data.FastString (FastString, mkFastString)
251 import GHC.Types.Id
252 import GHC.Types.Literal
253 import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
254 import GHC.Types.Id.Make (voidPrimId, voidArgId)
255 import GHC.Utils.Monad (mapAccumLM)
256 import GHC.Utils.Outputable
257 import GHC.Utils.Panic
258 import GHC.Utils.Panic.Plain
259 import GHC.Types.RepType
260 import GHC.Stg.Syntax
261 import GHC.Core.Type
262 import GHC.Builtin.Types.Prim (intPrimTy)
263 import GHC.Builtin.Types
264 import GHC.Types.Unique.Supply
265 import GHC.Utils.Misc
266 import GHC.Types.Var.Env
267
268 import Data.Bifunctor (second)
269 import Data.Maybe (mapMaybe)
270 import qualified Data.IntMap as IM
271
272 --------------------------------------------------------------------------------
273
274 -- | A mapping from binders to the Ids they were expanded/renamed to.
275 --
276 -- x :-> MultiVal [a,b,c] in rho
277 --
278 -- iff x's typePrimRep is not a singleton, or equivalently
279 -- x's type is an unboxed tuple, sum or void.
280 --
281 -- x :-> UnaryVal x'
282 --
283 -- iff x's RepType is UnaryRep or equivalently
284 -- x's type is not unboxed tuple, sum or void.
285 --
286 -- So
287 -- x :-> MultiVal [a] in rho
288 -- means x is represented by singleton tuple.
289 --
290 -- x :-> MultiVal [] in rho
291 -- means x is void.
292 --
293 -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
294 -- (i.e. no unboxed tuples, sums or voids)
295 --
296 type UnariseEnv = VarEnv UnariseVal
297
298 data UnariseVal
299 = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
300 | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation].
301
302 instance Outputable UnariseVal where
303 ppr (MultiVal args) = text "MultiVal" <+> ppr args
304 ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg
305
306 -- | Extend the environment, checking the UnariseEnv invariant.
307 extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
308 extendRho rho x (MultiVal args)
309 = assert (all (isNvUnaryType . stgArgType) args)
310 extendVarEnv rho x (MultiVal args)
311 extendRho rho x (UnaryVal val)
312 = assert (isNvUnaryType (stgArgType val))
313 extendVarEnv rho x (UnaryVal val)
314
315 --------------------------------------------------------------------------------
316
317 unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
318 unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
319
320 unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
321 unariseTopBinding rho (StgTopLifted bind)
322 = StgTopLifted <$> unariseBinding rho bind
323 unariseTopBinding _ bind@StgTopStringLit{} = return bind
324
325 unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
326 unariseBinding rho (StgNonRec x rhs)
327 = StgNonRec x <$> unariseRhs rho rhs
328 unariseBinding rho (StgRec xrhss)
329 = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
330
331 unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
332 unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
333 = do (rho', args1) <- unariseFunArgBinders rho args
334 expr' <- unariseExpr rho' expr
335 return (StgRhsClosure ext ccs update_flag args1 expr')
336
337 unariseRhs rho (StgRhsCon ccs con mu ts args)
338 = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
339 return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
340
341 --------------------------------------------------------------------------------
342
343 unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
344
345 unariseExpr rho e@(StgApp f [])
346 = case lookupVarEnv rho f of
347 Just (MultiVal args) -- Including empty tuples
348 -> return (mkTuple args)
349 Just (UnaryVal (StgVarArg f'))
350 -> return (StgApp f' [])
351 Just (UnaryVal (StgLitArg f'))
352 -> return (StgLit f')
353 Nothing
354 -> return e
355
356 unariseExpr rho e@(StgApp f args)
357 = return (StgApp f' (unariseFunArgs rho args))
358 where
359 f' = case lookupVarEnv rho f of
360 Just (UnaryVal (StgVarArg f')) -> f'
361 Nothing -> f
362 err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err)
363 -- Can't happen because 'args' is non-empty, and
364 -- a tuple or sum cannot be applied to anything
365
366 unariseExpr _ (StgLit l)
367 = return (StgLit l)
368
369 unariseExpr rho (StgConApp dc n args ty_args)
370 | Just args' <- unariseMulti_maybe rho dc args ty_args
371 = return (mkTuple args')
372
373 | otherwise
374 , let args' = unariseConArgs rho args
375 = return (StgConApp dc n args' (map stgArgType args'))
376
377 unariseExpr rho (StgOpApp op args ty)
378 = return (StgOpApp op (unariseFunArgs rho args) ty)
379
380 unariseExpr rho (StgCase scrut bndr alt_ty alts)
381 -- tuple/sum binders in the scrutinee can always be eliminated
382 | StgApp v [] <- scrut
383 , Just (MultiVal xs) <- lookupVarEnv rho v
384 = elimCase rho xs bndr alt_ty alts
385
386 -- Handle strict lets for tuples and sums:
387 -- case (# a,b #) of r -> rhs
388 -- and analogously for sums
389 | StgConApp dc _n args ty_args <- scrut
390 , Just args' <- unariseMulti_maybe rho dc args ty_args
391 = elimCase rho args' bndr alt_ty alts
392
393 -- See (3) of Note [Rubbish literals] in GHC.Types.Literal
394 | StgLit lit <- scrut
395 , Just args' <- unariseRubbish_maybe lit
396 = elimCase rho args' bndr alt_ty alts
397
398 -- general case
399 | otherwise
400 = do scrut' <- unariseExpr rho scrut
401 alts' <- unariseAlts rho alt_ty bndr alts
402 return (StgCase scrut' bndr alt_ty alts')
403 -- bndr may have a unboxed sum/tuple type but it will be
404 -- dead after unarise (checked in GHC.Stg.Lint)
405
406 unariseExpr rho (StgLet ext bind e)
407 = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
408
409 unariseExpr rho (StgLetNoEscape ext bind e)
410 = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
411
412 unariseExpr rho (StgTick tick e)
413 = StgTick tick <$> unariseExpr rho e
414
415 -- Doesn't return void args.
416 unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
417 unariseMulti_maybe rho dc args ty_args
418 | isUnboxedTupleDataCon dc
419 = Just (unariseConArgs rho args)
420
421 | isUnboxedSumDataCon dc
422 , let args1 = assert (isSingleton args) (unariseConArgs rho args)
423 = Just (mkUbxSum dc ty_args args1)
424
425 | otherwise
426 = Nothing
427
428 -- Doesn't return void args.
429 unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
430 unariseRubbish_maybe (LitRubbish rep)
431 | [prep] <- preps
432 , not (isVoidRep prep)
433 = Nothing -- Single, non-void PrimRep. Nothing to do!
434
435 | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase
436 = Just [ StgLitArg (LitRubbish (primRepToType prep))
437 | prep <- preps, not (isVoidRep prep) ]
438 where
439 preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep
440
441 unariseRubbish_maybe _ = Nothing
442
443 --------------------------------------------------------------------------------
444
445 elimCase :: UnariseEnv
446 -> [OutStgArg] -- non-void args
447 -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
448
449 elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
450 = do let rho1 = extendRho rho bndr (MultiVal args)
451 rho2
452 | isUnboxedTupleBndr bndr
453 = mapTupleIdBinders bndrs args rho1
454 | otherwise
455 = assert (isUnboxedSumBndr bndr) $
456 if null bndrs then rho1
457 else mapSumIdBinders bndrs args rho1
458
459 unariseExpr rho2 rhs
460
461 elimCase rho args bndr (MultiValAlt _) alts
462 | isUnboxedSumBndr bndr
463 = do let (tag_arg : real_args) = args
464 tag_bndr <- mkId (mkFastString "tag") tagTy
465 -- this won't be used but we need a binder anyway
466 let rho1 = extendRho rho bndr (MultiVal args)
467 scrut' = case tag_arg of
468 StgVarArg v -> StgApp v []
469 StgLitArg l -> StgLit l
470
471 alts' <- unariseSumAlts rho1 real_args alts
472 return (StgCase scrut' tag_bndr tagAltTy alts')
473
474 elimCase _ args bndr alt_ty alts
475 = pprPanic "elimCase - unhandled case"
476 (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts)
477
478 --------------------------------------------------------------------------------
479
480 unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
481 unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
482 | isUnboxedTupleBndr bndr
483 = do (rho', ys) <- unariseConArgBinder rho bndr
484 e' <- unariseExpr rho' e
485 return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
486
487 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
488 | isUnboxedTupleBndr bndr
489 = do (rho', ys1) <- unariseConArgBinders rho ys
490 massert (ys1 `lengthIs` n)
491 let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
492 e' <- unariseExpr rho'' e
493 return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
494
495 unariseAlts _ (MultiValAlt _) bndr alts
496 | isUnboxedTupleBndr bndr
497 = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)
498
499 -- In this case we don't need to scrutinize the tag bit
500 unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
501 | isUnboxedSumBndr bndr
502 = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
503 rhs' <- unariseExpr rho_sum_bndrs rhs
504 return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
505
506 unariseAlts rho (MultiValAlt _) bndr alts
507 | isUnboxedSumBndr bndr
508 = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
509 alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
510 let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
511 return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
512 scrt_bndrs,
513 inner_case) ]
514
515 unariseAlts rho _ _ alts
516 = mapM (\alt -> unariseAlt rho alt) alts
517
518 unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
519 unariseAlt rho (con, xs, e)
520 = do (rho', xs') <- unariseConArgBinders rho xs
521 (con, xs',) <$> unariseExpr rho' e
522
523 --------------------------------------------------------------------------------
524
525 -- | Make alternatives that match on the tag of a sum
526 -- (i.e. generate LitAlts for the tag)
527 unariseSumAlts :: UnariseEnv
528 -> [StgArg] -- sum components _excluding_ the tag bit.
529 -> [StgAlt] -- original alternative with sum LHS
530 -> UniqSM [StgAlt]
531 unariseSumAlts env args alts
532 = do alts' <- mapM (unariseSumAlt env args) alts
533 return (mkDefaultLitAlt alts')
534
535 unariseSumAlt :: UnariseEnv
536 -> [StgArg] -- sum components _excluding_ the tag bit.
537 -> StgAlt -- original alternative with sum LHS
538 -> UniqSM StgAlt
539 unariseSumAlt rho _ (DEFAULT, _, e)
540 = ( DEFAULT, [], ) <$> unariseExpr rho e
541
542 unariseSumAlt rho args (DataAlt sumCon, bs, e)
543 = do let rho' = mapSumIdBinders bs args rho
544 e' <- unariseExpr rho' e
545 return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )
546
547 unariseSumAlt _ scrt alt
548 = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)
549
550 --------------------------------------------------------------------------------
551
552 mapTupleIdBinders
553 :: [InId] -- Un-processed binders of a tuple alternative.
554 -- Can have void binders.
555 -> [OutStgArg] -- Arguments that form the tuple (after unarisation).
556 -- Can't have void args.
557 -> UnariseEnv
558 -> UnariseEnv
559 mapTupleIdBinders ids args0 rho0
560 = assert (not (any (isVoidTy . stgArgType) args0)) $
561 let
562 ids_unarised :: [(Id, [PrimRep])]
563 ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
564
565 map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
566 map_ids rho [] _ = rho
567 map_ids rho ((x, x_reps) : xs) args =
568 let
569 x_arity = length x_reps
570 (x_args, args') =
571 assert (args `lengthAtLeast` x_arity)
572 splitAt x_arity args
573
574 rho'
575 | x_arity == 1
576 = assert (x_args `lengthIs` 1)
577 extendRho rho x (UnaryVal (head x_args))
578 | otherwise
579 = extendRho rho x (MultiVal x_args)
580 in
581 map_ids rho' xs args'
582 in
583 map_ids rho0 ids_unarised args0
584
585 mapSumIdBinders
586 :: [InId] -- Binder of a sum alternative (remember that sum patterns
587 -- only have one binder, so this list should be a singleton)
588 -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
589 -- Can't have void args.
590 -> UnariseEnv
591 -> UnariseEnv
592
593 mapSumIdBinders [id] args rho0
594 = assert (not (any (isVoidTy . stgArgType) args)) $
595 let
596 arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
597 id_slots = map primRepSlot $ typePrimRep (idType id)
598 layout1 = layoutUbxSum arg_slots id_slots
599 in
600 if isMultiValBndr id
601 then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
602 else assert (layout1 `lengthIs` 1)
603 extendRho rho0 id (UnaryVal (args !! head layout1))
604
605 mapSumIdBinders ids sum_args _
606 = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
607
608 -- | Build a unboxed sum term from arguments of an alternative.
609 --
610 -- Example, for (# x | #) :: (# (# #) | Int #) we call
611 --
612 -- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
613 --
614 -- which returns
615 --
616 -- [ 1#, rubbish ]
617 --
618 mkUbxSum
619 :: DataCon -- Sum data con
620 -> [Type] -- Type arguments of the sum data con
621 -> [OutStgArg] -- Actual arguments of the alternative.
622 -> [OutStgArg] -- Final tuple arguments
623 mkUbxSum dc ty_args args0
624 = let
625 (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
626 -- drop tag slot
627
628 tag = dataConTag dc
629
630 layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
631 tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag))
632 arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
633
634 mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
635 mkTupArgs _ [] _
636 = []
637 mkTupArgs arg_idx (slot : slots_left) arg_map
638 | Just stg_arg <- IM.lookup arg_idx arg_map
639 = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
640 | otherwise
641 = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
642 in
643 tag_arg : mkTupArgs 0 sum_slots arg_idxs
644
645
646 -- | Return a rubbish value for the given slot type.
647 --
648 -- We use the following rubbish values:
649 -- * Literals: 0 or 0.0
650 -- * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
651 --
652 -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make"
653 --
654 ubxSumRubbishArg :: SlotTy -> StgArg
655 ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
656 ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
657 ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0)
658 ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0)
659 ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0)
660 ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
661
662 --------------------------------------------------------------------------------
663
664 {-
665 For arguments (StgArg) and binders (Id) we have two kind of unarisation:
666
667 - When unarising function arg binders and arguments, we don't want to remove
668 void binders and arguments. For example,
669
670 f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
671 f x y z = <body>
672
673 Here after unarise we should still get a function with arity 3. Similarly
674 in the call site we shouldn't remove void arguments:
675
676 f (# (# #), (# #) #) voidId rw
677
678 When unarising <body>, we extend the environment with these binders:
679
680 x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
681
682 Because their rep types are `MultiRep []` (aka. void). This means that when
683 we see `x` in a function argument position, we actually replace it with a
684 void argument. When we see it in a DataCon argument position, we just get
685 rid of it, because DataCon applications in STG are always saturated.
686
687 - When unarising case alternative binders we remove void binders, but we
688 still update the environment the same way, because those binders may be
689 used in the RHS. Example:
690
691 case x of y {
692 (# x1, x2, x3 #) -> <RHS>
693 }
694
695 We know that y can't be void, because we don't scrutinize voids, so x will
696 be unarised to some number of arguments, and those arguments will have at
697 least one non-void thing. So in the rho we will have something like:
698
699 x :-> MultiVal [xu1, xu2]
700
701 Now, after we eliminate void binders in the pattern, we get exactly the same
702 number of binders, and extend rho again with these:
703
704 x1 :-> UnaryVal xu1
705 x2 :-> MultiVal [] -- x2 is void
706 x3 :-> UnaryVal xu2
707
708 Now when we see x2 in a function argument position or in return position, we
709 generate void#. In constructor argument position, we just remove it.
710
711 So in short, when we have a void id,
712
713 - We keep it if it's a lambda argument binder or
714 in argument position of an application.
715
716 - We remove it if it's a DataCon field binder or
717 in argument position of a DataCon application.
718 -}
719
720 unariseArgBinder
721 :: Bool -- data con arg?
722 -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
723 unariseArgBinder is_con_arg rho x =
724 case typePrimRep (idType x) of
725 []
726 | is_con_arg
727 -> return (extendRho rho x (MultiVal []), [])
728 | otherwise -- fun arg, do not remove void binders
729 -> return (extendRho rho x (MultiVal []), [voidArgId])
730
731 [rep]
732 -- Arg represented as single variable, but original type may still be an
733 -- unboxed sum/tuple, e.g. (# Void# | Void# #).
734 --
735 -- While not unarising the binder in this case does not break any programs
736 -- (because it unarises to a single variable), it triggers StgLint as we
737 -- break the post-unarisation invariant that says unboxed tuple/sum
738 -- binders should vanish. See Note [Post-unarisation invariants].
739 | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
740 -> do x' <- mkId (mkFastString "us") (primRepToType rep)
741 return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
742 | otherwise
743 -> return (rho, [x])
744
745 reps -> do
746 xs <- mkIds (mkFastString "us") (map primRepToType reps)
747 return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
748
749 --------------------------------------------------------------------------------
750
751 -- | MultiVal a function argument. Never returns an empty list.
752 unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
753 unariseFunArg rho (StgVarArg x) =
754 case lookupVarEnv rho x of
755 Just (MultiVal []) -> [voidArg] -- NB: do not remove void args
756 Just (MultiVal as) -> as
757 Just (UnaryVal arg) -> [arg]
758 Nothing -> [StgVarArg x]
759 unariseFunArg _ arg = [arg]
760
761 unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
762 unariseFunArgs = concatMap . unariseFunArg
763
764 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
765 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
766
767 -- Result list of binders is never empty
768 unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
769 unariseFunArgBinder = unariseArgBinder False
770
771 --------------------------------------------------------------------------------
772
773 -- | MultiVal a DataCon argument. Returns an empty list when argument is void.
774 unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
775 unariseConArg rho (StgVarArg x) =
776 case lookupVarEnv rho x of
777 Just (UnaryVal arg) -> [arg]
778 Just (MultiVal as) -> as -- 'as' can be empty
779 Nothing
780 | isVoidTy (idType x) -> [] -- e.g. C realWorld#
781 -- Here realWorld# is not in the envt, but
782 -- is a void, and so should be eliminated
783 | otherwise -> [StgVarArg x]
784 unariseConArg _ arg@(StgLitArg lit)
785 | Just as <- unariseRubbish_maybe lit
786 = as
787 | otherwise
788 = assert (not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals
789 [arg]
790
791 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
792 unariseConArgs = concatMap . unariseConArg
793
794 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
795 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
796
797 -- Different from `unariseFunArgBinder`: result list of binders may be empty.
798 -- See DataCon applications case in Note [Post-unarisation invariants].
799 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
800 unariseConArgBinder = unariseArgBinder True
801
802 --------------------------------------------------------------------------------
803
804 mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
805 mkIds fs tys = mapM (mkId fs) tys
806
807 mkId :: FastString -> UnaryType -> UniqSM Id
808 mkId s t = mkSysLocalM s Many t
809
810 isMultiValBndr :: Id -> Bool
811 isMultiValBndr id
812 | [_] <- typePrimRep (idType id)
813 = False
814 | otherwise
815 = True
816
817 isUnboxedSumBndr :: Id -> Bool
818 isUnboxedSumBndr = isUnboxedSumType . idType
819
820 isUnboxedTupleBndr :: Id -> Bool
821 isUnboxedTupleBndr = isUnboxedTupleType . idType
822
823 mkTuple :: [StgArg] -> StgExpr
824 mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args)
825
826 tagAltTy :: AltType
827 tagAltTy = PrimAlt IntRep
828
829 tagTy :: Type
830 tagTy = intPrimTy
831
832 voidArg :: StgArg
833 voidArg = StgVarArg voidPrimId
834
835 mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
836 -- We have an exhauseive list of literal alternatives
837 -- 1# -> e1
838 -- 2# -> e2
839 -- Since they are exhaustive, we can replace one with DEFAULT, to avoid
840 -- generating a final test. Remember, the DEFAULT comes first if it exists.
841 mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
842 mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
843 mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
844 mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)
845
846 pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc
847 pprPanicAlts alts = ppr (map pprPanicAlt alts)
848
849 pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc
850 pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)