|
|
1
|
+{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dumpdir dumps #-}
|
|
|
2
|
+
|
|
1
|
3
|
{-
|
|
2
|
4
|
(c) The University of Glasgow 2006
|
|
3
|
5
|
(c) The AQUA Project, Glasgow University, 1994-1998
|
| ... |
... |
@@ -335,6 +337,7 @@ isValFun (Lam b e) | isRuntimeVar b = True |
|
335
|
337
|
| otherwise = isValFun e
|
|
336
|
338
|
isValFun _ = False
|
|
337
|
339
|
|
|
|
340
|
+{-# NOINLINE calcUnfoldingGuidance #-}
|
|
338
|
341
|
calcUnfoldingGuidance
|
|
339
|
342
|
:: UnfoldingOpts
|
|
340
|
343
|
-> Bool -- Definitely a top-level, bottoming binding
|
| ... |
... |
@@ -567,43 +570,43 @@ sizeExpr :: UnfoldingOpts |
|
567
|
570
|
-- Forcing bOMB_OUT_SIZE early prevents repeated
|
|
568
|
571
|
-- unboxing of the Int argument.
|
|
569
|
572
|
sizeExpr opts !bOMB_OUT_SIZE top_args expr
|
|
570
|
|
- = size_up expr
|
|
|
573
|
+ = size_up sizeZero expr
|
|
571
|
574
|
where
|
|
572
|
|
- size_up (Cast e _) = size_up e
|
|
573
|
|
- size_up (Tick _ e) = size_up e
|
|
574
|
|
- size_up (Type _) = sizeZero -- Types cost nothing
|
|
575
|
|
- size_up (Coercion _) = sizeZero
|
|
576
|
|
- size_up (Lit lit) = sizeN (litSize lit)
|
|
577
|
|
- size_up (Var f) | isZeroBitId f = sizeZero
|
|
578
|
|
- -- Make sure we get constructor discounts even
|
|
579
|
|
- -- on nullary constructors
|
|
580
|
|
- | otherwise = size_up_call f [] 0
|
|
581
|
|
-
|
|
582
|
|
- size_up (App fun arg)
|
|
583
|
|
- | isTyCoArg arg = size_up fun
|
|
584
|
|
- | otherwise = size_up arg `addSizeNSD`
|
|
585
|
|
- size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0)
|
|
586
|
|
-
|
|
587
|
|
- size_up (Lam b e)
|
|
588
|
|
- | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)
|
|
589
|
|
- | otherwise = size_up e
|
|
590
|
|
-
|
|
591
|
|
- size_up (Let (NonRec binder rhs) body)
|
|
592
|
|
- = size_up_rhs (binder, rhs) `addSizeNSD`
|
|
593
|
|
- size_up body `addSizeN`
|
|
594
|
|
- size_up_alloc binder
|
|
595
|
|
-
|
|
596
|
|
- size_up (Let (Rec pairs) body)
|
|
597
|
|
- = foldr (addSizeNSD . size_up_rhs)
|
|
598
|
|
- (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))
|
|
599
|
|
- pairs
|
|
600
|
|
-
|
|
601
|
|
- size_up (Case e _ _ alts) = case nonEmpty alts of
|
|
602
|
|
- Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee
|
|
|
575
|
+ size_up :: ExprSize -> CoreExpr -> ExprSize
|
|
|
576
|
+ size_up s (Cast e _) = size_up s e
|
|
|
577
|
+ size_up s (Tick _ e) = size_up s e
|
|
|
578
|
+ size_up s (Type _) = s -- Types cost nothing
|
|
|
579
|
+ size_up s (Coercion _) = s
|
|
|
580
|
+ size_up s (Lit lit) = addSizeNSD (sizeN (litSize lit)) s
|
|
|
581
|
+ size_up s (Var f) | isZeroBitId f = s
|
|
|
582
|
+ -- Make sure we get constructor discounts even
|
|
|
583
|
+ -- on nullary constructors
|
|
|
584
|
+ | otherwise = size_up_call s f [] 0
|
|
|
585
|
+
|
|
|
586
|
+ size_up s (App fun arg)
|
|
|
587
|
+ | isTyCoArg arg = size_up s fun
|
|
|
588
|
+ | otherwise = size_up_app (stripDiscounts $ size_up s arg)
|
|
|
589
|
+ fun [arg] (if isZeroBitExpr arg then 1 else 0)
|
|
|
590
|
+
|
|
|
591
|
+ size_up s (Lam b e)
|
|
|
592
|
+ | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e)
|
|
|
593
|
+ | otherwise = size_up s e
|
|
|
594
|
+
|
|
|
595
|
+ size_up s (Let (NonRec binder rhs) body)
|
|
|
596
|
+ = let rhs_s = size_up_rhs s (binder, rhs)
|
|
|
597
|
+ in size_up (stripDiscounts $ rhs_s `addSizeN` size_up_alloc binder) body
|
|
|
598
|
+
|
|
|
599
|
+
|
|
|
600
|
+ size_up s (Let (Rec pairs) body)
|
|
|
601
|
+ = size_up (stripDiscounts (foldr (flip size_up_rhs) s pairs))
|
|
|
602
|
+ body
|
|
|
603
|
+
|
|
|
604
|
+ size_up s (Case e _ _ alts) = case nonEmpty alts of
|
|
|
605
|
+ Nothing -> size_up s e -- case e of {} never returns, so take size of scrutinee
|
|
603
|
606
|
Just alts
|
|
604
|
607
|
| Just v <- is_top_arg e -> -- We are scrutinising an argument variable
|
|
605
|
608
|
let
|
|
606
|
|
- alt_sizes = NE.map size_up_alt alts
|
|
|
609
|
+ alt_sizes = NE.map (size_up_alt s) alts
|
|
607
|
610
|
|
|
608
|
611
|
-- alts_size tries to compute a good discount for
|
|
609
|
612
|
-- the case when we are scrutinising an argument variable
|
| ... |
... |
@@ -625,18 +628,19 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
625
|
628
|
|
|
626
|
629
|
alts_size tot_size _ = tot_size
|
|
627
|
630
|
in
|
|
628
|
|
- alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
|
|
629
|
|
- (foldr1 maxSize alt_sizes)
|
|
|
631
|
+ s `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
|
|
|
632
|
+ (foldr1 maxSize alt_sizes)
|
|
630
|
633
|
-- Good to inline if an arg is scrutinised, because
|
|
631
|
634
|
-- that may eliminate allocation in the caller
|
|
632
|
635
|
-- And it eliminates the case itself
|
|
633
|
636
|
|
|
634
|
|
- | otherwise -> size_up e `addSizeNSD`
|
|
635
|
|
- foldr (addAltSize . size_up_alt) case_size alts
|
|
|
637
|
+ | otherwise -> let case_s = size_up s e `addSizeNSD` case_size
|
|
|
638
|
+ in foldr (addAltSize . size_up_alt case_s) case_s alts
|
|
636
|
639
|
|
|
637
|
640
|
where
|
|
638
|
641
|
is_top_arg (Var v) | v `elem` top_args = Just v
|
|
639
|
642
|
is_top_arg (Cast e _) = is_top_arg e
|
|
|
643
|
+ is_top_arg (Tick _t e) = is_top_arg e
|
|
640
|
644
|
is_top_arg _ = Nothing
|
|
641
|
645
|
|
|
642
|
646
|
where
|
| ... |
... |
@@ -675,44 +679,52 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
675
|
679
|
| otherwise
|
|
676
|
680
|
= False
|
|
677
|
681
|
|
|
678
|
|
- size_up_rhs (bndr, rhs)
|
|
|
682
|
+ size_up_rhs :: ExprSize -> (Id, CoreExpr) -> ExprSize
|
|
|
683
|
+ size_up_rhs s (bndr, rhs)
|
|
679
|
684
|
| JoinPoint join_arity <- idJoinPointHood bndr
|
|
680
|
685
|
-- Skip arguments to join point
|
|
681
|
686
|
, (_bndrs, body) <- collectNBinders join_arity rhs
|
|
682
|
|
- = size_up body
|
|
|
687
|
+ = size_up s body
|
|
683
|
688
|
| otherwise
|
|
684
|
|
- = size_up rhs
|
|
|
689
|
+ = size_up s rhs
|
|
685
|
690
|
|
|
686
|
691
|
------------
|
|
687
|
692
|
-- size_up_app is used when there's ONE OR MORE value args
|
|
688
|
|
- size_up_app (App fun arg) args voids
|
|
689
|
|
- | isTyCoArg arg = size_up_app fun args voids
|
|
690
|
|
- | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1)
|
|
691
|
|
- | otherwise = size_up arg `addSizeNSD`
|
|
692
|
|
- size_up_app fun (arg:args) voids
|
|
693
|
|
- size_up_app (Var fun) args voids = size_up_call fun args voids
|
|
694
|
|
- size_up_app (Tick _ expr) args voids = size_up_app expr args voids
|
|
695
|
|
- size_up_app (Cast expr _) args voids = size_up_app expr args voids
|
|
696
|
|
- size_up_app other args voids = size_up other `addSizeN`
|
|
697
|
|
- callSize (length args) voids
|
|
|
693
|
+ size_up_app :: ExprSize -> CoreExpr -> [CoreExpr] -> Int -> ExprSize
|
|
|
694
|
+ size_up_app s (App fun arg) args voids
|
|
|
695
|
+ | isTyCoArg arg = size_up_app s fun args voids
|
|
|
696
|
+ | isZeroBitExpr arg = size_up_app s fun (arg:args) (voids + 1)
|
|
|
697
|
+ | otherwise = let arg_size = stripDiscounts $ size_up s arg
|
|
|
698
|
+ in size_up_app arg_size fun (arg:args) voids
|
|
|
699
|
+ size_up_app s (Var fun) args voids = size_up_call s fun args voids
|
|
|
700
|
+ size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids
|
|
|
701
|
+ size_up_app s (Cast expr _) args voids = size_up_app s expr args voids
|
|
|
702
|
+ size_up_app s other args voids = size_up (s `addSizeN` callSize (length args) voids) other
|
|
|
703
|
+
|
|
698
|
704
|
-- if the lhs is not an App or a Var, or an invisible thing like a
|
|
699
|
705
|
-- Tick or Cast, then we should charge for a complete call plus the
|
|
700
|
706
|
-- size of the lhs itself.
|
|
701
|
707
|
|
|
702
|
708
|
------------
|
|
703
|
|
- size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
|
|
704
|
|
- size_up_call fun val_args voids
|
|
705
|
|
- = case idDetails fun of
|
|
706
|
|
- FCallId _ -> sizeN (callSize (length val_args) voids)
|
|
707
|
|
- DataConWorkId dc -> conSize dc (length val_args)
|
|
708
|
|
- PrimOpId op _ -> primOpSize op (length val_args)
|
|
709
|
|
- ClassOpId cls _ -> classOpSize opts cls top_args val_args
|
|
710
|
|
- _ | fun `hasKey` buildIdKey -> buildSize
|
|
711
|
|
- | fun `hasKey` augmentIdKey -> augmentSize
|
|
712
|
|
- | otherwise -> funSize opts top_args fun (length val_args) voids
|
|
|
709
|
+ size_up_call :: ExprSize -> Id -> [CoreExpr] -> Int -> ExprSize
|
|
|
710
|
+ size_up_call s fun val_args voids
|
|
|
711
|
+ = let call_size = case idDetails fun of
|
|
|
712
|
+ FCallId _ -> sizeN (callSize (length val_args) voids)
|
|
|
713
|
+ DataConWorkId dc -> conSize dc (length val_args)
|
|
|
714
|
+ PrimOpId op _ -> primOpSize op (length val_args)
|
|
|
715
|
+ ClassOpId cls _ -> classOpSize opts cls top_args val_args
|
|
|
716
|
+ _ | fun `hasKey` buildIdKey -> buildSize
|
|
|
717
|
+ | fun `hasKey` augmentIdKey -> augmentSize
|
|
|
718
|
+ | otherwise -> funSize opts top_args fun (length val_args) voids
|
|
|
719
|
+ in s `addSizeNSD` call_size
|
|
713
|
720
|
|
|
714
|
721
|
------------
|
|
715
|
|
- size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10
|
|
|
722
|
+ -- size_up_alt returns on the alternatives size, not including the accumulated size passed in unless we reach TooBig
|
|
|
723
|
+ size_up_alt TooBig _ = TooBig
|
|
|
724
|
+ size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) =
|
|
|
725
|
+ size_up (sizeN $ s + 10) rhs
|
|
|
726
|
+ `addSizeN` (-s) -- Why add and then subtract s? If the expression is already large we will bomb out early this way.
|
|
|
727
|
+
|
|
716
|
728
|
-- Don't charge for args, so that wrappers look cheap
|
|
717
|
729
|
-- (See comments about wrappers with Case)
|
|
718
|
730
|
--
|
| ... |
... |
@@ -753,6 +765,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
753
|
765
|
(xs `unionBags` ys)
|
|
754
|
766
|
d2 -- Ignore d1
|
|
755
|
767
|
|
|
|
768
|
+ stripDiscounts TooBig = TooBig
|
|
|
769
|
+ stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0)
|
|
|
770
|
+
|
|
756
|
771
|
-- don't count expressions such as State# RealWorld
|
|
757
|
772
|
-- exclude join points, because they can be rep-polymorphic
|
|
758
|
773
|
-- and typePrimRep will crash
|