|
|
1
|
+{-# LANGUAGE DataKinds #-}
|
|
|
2
|
+
|
|
1
|
3
|
{-
|
|
2
|
4
|
(c) The University of Glasgow 2006
|
|
3
|
5
|
(c) The AQUA Project, Glasgow University, 1994-1998
|
| ... |
... |
@@ -554,56 +556,69 @@ uncondInlineJoin bndrs body |
|
554
|
556
|
go_arg (Var f) = Just $! f `notElem` bndrs
|
|
555
|
557
|
go_arg _ = Nothing
|
|
556
|
558
|
|
|
557
|
|
-
|
|
558
|
559
|
sizeExpr :: UnfoldingOpts
|
|
559
|
|
- -> Int -- Bomb out if it gets bigger than this
|
|
|
560
|
+ -> PlainSize -- Bomb out if it gets bigger than this
|
|
560
|
561
|
-> [Id] -- Arguments; we're interested in which of these
|
|
561
|
562
|
-- get case'd
|
|
562
|
563
|
-> CoreExpr
|
|
563
|
|
- -> ExprSize
|
|
|
564
|
+ -> ExprSize WithDiscount
|
|
564
|
565
|
|
|
565
|
566
|
-- Note [Computing the size of an expression]
|
|
566
|
567
|
|
|
567
|
568
|
-- Forcing bOMB_OUT_SIZE early prevents repeated
|
|
568
|
569
|
-- unboxing of the Int argument.
|
|
569
|
570
|
sizeExpr opts !bOMB_OUT_SIZE top_args expr
|
|
570
|
|
- = size_up expr
|
|
|
571
|
+ = case size_up 0 expr of
|
|
|
572
|
+ -- We skip the size check in some places, in exchange for checking it one last time here.
|
|
|
573
|
+ TooBig -> TooBig
|
|
|
574
|
+ size@(SizeIs size_n _arg_dc _scrut_dc)
|
|
|
575
|
+ | size_n > bOMB_OUT_SIZE -> TooBig
|
|
|
576
|
+ | otherwise -> size
|
|
571
|
577
|
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
|
|
|
578
|
+ -- (size_up s e) returns `s` plus the size of `e`
|
|
|
579
|
+ size_up :: PlainSize -> CoreExpr -> ExprSize WithDiscount
|
|
|
580
|
+ size_up acc_size _e | acc_size > bOMB_OUT_SIZE = TooBig
|
|
|
581
|
+ size_up acc_size (Cast e _) = size_up acc_size e
|
|
|
582
|
+ size_up acc_size (Tick _ e) = size_up acc_size e
|
|
|
583
|
+ size_up acc_size (Type _) = sizeND acc_size -- Types add no cost
|
|
|
584
|
+ size_up acc_size (Coercion _) = sizeND acc_size
|
|
|
585
|
+ size_up acc_size (Lit lit) = sizeND (acc_size + litSize lit)
|
|
|
586
|
+ size_up acc_size (Var f) | isZeroBitId f = sizeND acc_size
|
|
|
587
|
+ -- Make sure we get constructor discounts even
|
|
|
588
|
+ -- on nullary constructors
|
|
|
589
|
+ | otherwise = size_up_call acc_size emptyBag f [] 0
|
|
|
590
|
+
|
|
|
591
|
+ size_up acc_size (App fun arg)
|
|
|
592
|
+ | isTyCoArg arg = size_up acc_size fun
|
|
|
593
|
+ | otherwise = case size_up acc_size arg of
|
|
|
594
|
+ TooBig -> TooBig
|
|
|
595
|
+ SizeIs acc_size' acc_args' _d -> size_up_app acc_size' acc_args'
|
|
|
596
|
+ fun [arg] (if isZeroBitExpr arg then 1 else 0)
|
|
|
597
|
+
|
|
|
598
|
+ size_up acc_size (Lam b e)
|
|
|
599
|
+ | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (acc_size+10) e)
|
|
|
600
|
+ | otherwise = size_up acc_size e
|
|
|
601
|
+
|
|
|
602
|
+ size_up acc_size (Let (NonRec binder rhs) body)
|
|
|
603
|
+ = case size_up_let acc_size emptyBag (binder, rhs) of
|
|
|
604
|
+ TooBig -> TooBig
|
|
|
605
|
+ SizeIs acc_size' acc_args' _d -> size_up acc_size' body `addSizeB` acc_args'
|
|
|
606
|
+
|
|
|
607
|
+ size_up acc_size (Let (Rec pairs) body)
|
|
|
608
|
+ = do_pairs acc_size emptyBag pairs
|
|
|
609
|
+ where
|
|
|
610
|
+ do_pairs acc_size acc_args [] = size_up acc_size body `addSizeB` acc_args
|
|
|
611
|
+ do_pairs acc_size acc_args (pair:pairs) =
|
|
|
612
|
+ case size_up_let acc_size acc_args pair of
|
|
|
613
|
+ TooBig -> TooBig
|
|
|
614
|
+ SizeIs acc_size' acc_args' _d -> do_pairs acc_size' acc_args' pairs
|
|
|
615
|
+
|
|
|
616
|
+ size_up acc_size (Case e _ _ alts) = case nonEmpty alts of
|
|
|
617
|
+ Nothing -> size_up acc_size e -- case e of {} never returns, so take size of scrutinee
|
|
603
|
618
|
Just alts
|
|
604
|
619
|
| Just v <- is_top_arg e -> -- We are scrutinising an argument variable
|
|
605
|
620
|
let
|
|
606
|
|
- alt_sizes = NE.map size_up_alt alts
|
|
|
621
|
+ alt_sizes = NE.map (size_up_alt acc_size) alts
|
|
607
|
622
|
|
|
608
|
623
|
-- alts_size tries to compute a good discount for
|
|
609
|
624
|
-- the case when we are scrutinising an argument variable
|
| ... |
... |
@@ -625,14 +640,15 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
625
|
640
|
|
|
626
|
641
|
alts_size tot_size _ = tot_size
|
|
627
|
642
|
in
|
|
628
|
|
- alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
|
|
629
|
|
- (foldr1 maxSize alt_sizes)
|
|
|
643
|
+ sizeN acc_size `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty
|
|
|
644
|
+ (foldr1 maxSize alt_sizes)
|
|
630
|
645
|
-- Good to inline if an arg is scrutinised, because
|
|
631
|
646
|
-- that may eliminate allocation in the caller
|
|
632
|
647
|
-- And it eliminates the case itself
|
|
633
|
648
|
|
|
634
|
|
- | otherwise -> size_up e `addSizeNSD`
|
|
635
|
|
- foldr (addAltSize . size_up_alt) case_size alts
|
|
|
649
|
+ | otherwise -> foldr (addAltSize . (size_up_alt acc_size))
|
|
|
650
|
+ (size_up (acc_size + case_size) e)
|
|
|
651
|
+ alts
|
|
636
|
652
|
|
|
637
|
653
|
where
|
|
638
|
654
|
is_top_arg (Var v) | v `elem` top_args = Just v
|
| ... |
... |
@@ -641,9 +657,10 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
641
|
657
|
is_top_arg _ = Nothing
|
|
642
|
658
|
|
|
643
|
659
|
where
|
|
|
660
|
+ case_size :: PlainSize
|
|
644
|
661
|
case_size
|
|
645
|
|
- | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
|
|
646
|
|
- | otherwise = sizeZero
|
|
|
662
|
+ | is_inline_scrut e, lengthAtMost alts 1 = (-10)
|
|
|
663
|
+ | otherwise = 0
|
|
647
|
664
|
-- Normally we don't charge for the case itself, but
|
|
648
|
665
|
-- we charge one per alternative (see size_up_alt,
|
|
649
|
666
|
-- below) to account for the cost of the info table
|
| ... |
... |
@@ -676,48 +693,64 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
676
|
693
|
| otherwise
|
|
677
|
694
|
= False
|
|
678
|
695
|
|
|
679
|
|
- size_up_rhs (bndr, rhs)
|
|
|
696
|
+ size_up_let :: PlainSize -> Bag (Id,Int) -> (Id, CoreExpr) -> ExprSize NoDiscount
|
|
|
697
|
+ size_up_let !acc_size acc_args (bndr, rhs)
|
|
680
|
698
|
| JoinPoint join_arity <- idJoinPointHood bndr
|
|
681
|
699
|
-- Skip arguments to join point
|
|
682
|
|
- , (_bndrs, body) <- collectNBinders join_arity rhs
|
|
683
|
|
- = size_up body
|
|
|
700
|
+ , (_bndrs, join_rhs) <- collectNBinders join_arity rhs
|
|
|
701
|
+ = (stripDiscounts $ size_up acc_size join_rhs) `addSizeB` acc_args
|
|
684
|
702
|
| otherwise
|
|
685
|
|
- = size_up rhs
|
|
|
703
|
+ = (stripDiscounts $ size_up (acc_size + size_up_alloc bndr) rhs) `addSizeB` acc_args
|
|
686
|
704
|
|
|
687
|
705
|
------------
|
|
688
|
706
|
-- size_up_app is used when there's ONE OR MORE value args
|
|
689
|
|
- size_up_app (App fun arg) args voids
|
|
690
|
|
- | isTyCoArg arg = size_up_app fun args voids
|
|
691
|
|
- | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1)
|
|
692
|
|
- | otherwise = size_up arg `addSizeNSD`
|
|
693
|
|
- size_up_app fun (arg:args) voids
|
|
694
|
|
- size_up_app (Var fun) args voids = size_up_call fun args voids
|
|
695
|
|
- size_up_app (Tick _ expr) args voids = size_up_app expr args voids
|
|
696
|
|
- size_up_app (Cast expr _) args voids = size_up_app expr args voids
|
|
697
|
|
- size_up_app other args voids = size_up other `addSizeN`
|
|
698
|
|
- callSize (length args) voids
|
|
|
707
|
+ size_up_app :: PlainSize -> Bag (Id,Int) -> CoreExpr -> [CoreExpr] -> Int -> ExprSize WithDiscount
|
|
|
708
|
+ size_up_app !acc_size acc_args (App fun arg) args voids
|
|
|
709
|
+ | isTyCoArg arg = size_up_app acc_size acc_args fun args voids
|
|
|
710
|
+ | isZeroBitExpr arg = size_up_app acc_size acc_args fun (arg:args) (voids + 1)
|
|
|
711
|
+ | otherwise = case size_up acc_size arg of
|
|
|
712
|
+ TooBig -> TooBig
|
|
|
713
|
+ SizeIs acc_size' acc_args' _ ->
|
|
|
714
|
+ size_up_app acc_size' acc_args' fun (arg:args) voids
|
|
|
715
|
+ `addSizeB` acc_args
|
|
|
716
|
+ size_up_app acc_size acc_args (Var fun) args voids = size_up_call acc_size acc_args fun args voids
|
|
|
717
|
+ size_up_app acc_size acc_args (Tick _ expr) args voids = size_up_app acc_size acc_args expr args voids
|
|
|
718
|
+ size_up_app acc_size acc_args (Cast expr _) args voids = size_up_app acc_size acc_args expr args voids
|
|
|
719
|
+ size_up_app acc_size acc_args other args voids = size_up (acc_size + callSize (length args) voids) other `addSizeB` acc_args
|
|
|
720
|
+
|
|
699
|
721
|
-- if the lhs is not an App or a Var, or an invisible thing like a
|
|
700
|
722
|
-- Tick or Cast, then we should charge for a complete call plus the
|
|
701
|
723
|
-- size of the lhs itself.
|
|
702
|
724
|
|
|
703
|
725
|
------------
|
|
704
|
|
- size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
|
|
705
|
|
- size_up_call fun val_args voids
|
|
706
|
|
- = case idDetails fun of
|
|
707
|
|
- FCallId _ -> sizeN (callSize (length val_args) voids)
|
|
708
|
|
- DataConWorkId dc -> conSize dc (length val_args)
|
|
709
|
|
- PrimOpId op _ -> primOpSize op (length val_args)
|
|
710
|
|
- ClassOpId cls _ -> classOpSize opts cls top_args val_args
|
|
711
|
|
- _ | fun `hasKey` buildIdKey -> buildSize
|
|
712
|
|
- | fun `hasKey` augmentIdKey -> augmentSize
|
|
713
|
|
- | otherwise -> funSize opts top_args fun (length val_args) voids
|
|
|
726
|
+ size_up_call :: PlainSize -> Bag (Id,Int) -> Id -> [CoreExpr] -> Int -> ExprSize WithDiscount
|
|
|
727
|
+ size_up_call !acc_size acc_args fun val_args voids
|
|
|
728
|
+ = let !n_args = length val_args
|
|
|
729
|
+ call_size = case idDetails fun of
|
|
|
730
|
+ FCallId _ -> withDiscount $ sizeN (callSize n_args voids)
|
|
|
731
|
+ DataConWorkId dc -> conSize dc n_args
|
|
|
732
|
+ PrimOpId op _ -> sizeND $ primOpSize op n_args
|
|
|
733
|
+ ClassOpId cls _ -> withDiscount $ classOpSize opts cls top_args val_args
|
|
|
734
|
+ _ | fun `hasKey` buildIdKey -> buildSize
|
|
|
735
|
+ | fun `hasKey` augmentIdKey -> augmentSize
|
|
|
736
|
+ | otherwise -> funSize opts top_args fun n_args voids
|
|
|
737
|
+ in mkSizeNoDiscount bOMB_OUT_SIZE acc_size acc_args `addSizeNSD` call_size
|
|
714
|
738
|
|
|
715
|
739
|
------------
|
|
716
|
|
- size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10
|
|
|
740
|
+ -- size_up_alt returns only the alternatives size, not counting the accumulated
|
|
|
741
|
+ -- size passed in unless we reach TooBig. This is to facility better discount
|
|
|
742
|
+ -- calculation based on the size of only the alternative.
|
|
|
743
|
+ -- size_up_alt acc_size acc_args = TooBig
|
|
|
744
|
+ size_up_alt acc_size (Alt _con _bndrs rhs) =
|
|
|
745
|
+ size_up acc_size rhs
|
|
|
746
|
+ -- Why add and then subtract s?
|
|
|
747
|
+ -- If the expression large enough this will ensure we bomb out early.
|
|
|
748
|
+ `addSizeND` (10 -acc_size)
|
|
|
749
|
+
|
|
717
|
750
|
-- Don't charge for args, so that wrappers look cheap
|
|
718
|
751
|
-- (See comments about wrappers with Case)
|
|
719
|
752
|
--
|
|
720
|
|
- -- IMPORTANT: *do* charge 1 for the alternative, else we
|
|
|
753
|
+ -- IMPORTANT: *do* charge 10 for the alternative, else we
|
|
721
|
754
|
-- find that giant case nests are treated as practically free
|
|
722
|
755
|
-- A good example is Foreign.C.Error.errnoToIOError
|
|
723
|
756
|
|
| ... |
... |
@@ -734,26 +767,40 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
734
|
767
|
------------
|
|
735
|
768
|
-- These addSize things have to be here because
|
|
736
|
769
|
-- I don't want to give them bOMB_OUT_SIZE as an argument
|
|
737
|
|
- addSizeN TooBig _ = TooBig
|
|
738
|
|
- addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d
|
|
|
770
|
+ addSizeND :: ExprSize WithDiscount -> Int -> ExprSize WithDiscount
|
|
|
771
|
+ addSizeND TooBig _ = TooBig
|
|
|
772
|
+ addSizeND (SizeIs n xs d) m = mkSizeDiscount bOMB_OUT_SIZE (n + m) xs d
|
|
739
|
773
|
|
|
|
774
|
+ addSizeB :: ExprSize a -> Bag (Id,Int) -> ExprSize a
|
|
|
775
|
+ addSizeB TooBig _ = TooBig
|
|
|
776
|
+ addSizeB (SizeIs sz bg1 dc) bg2 = SizeIs sz (bg1 `unionBags` bg2) dc
|
|
740
|
777
|
-- addAltSize is used to add the sizes of case alternatives
|
|
741
|
778
|
addAltSize TooBig _ = TooBig
|
|
742
|
779
|
addAltSize _ TooBig = TooBig
|
|
743
|
780
|
addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
|
|
744
|
|
- = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
|
|
|
781
|
+ = mkSizeDiscount bOMB_OUT_SIZE (n1 + n2)
|
|
745
|
782
|
(xs `unionBags` ys)
|
|
746
|
783
|
(d1 + d2) -- Note [addAltSize result discounts]
|
|
747
|
784
|
|
|
748
|
785
|
-- This variant ignores the result discount from its LEFT argument
|
|
749
|
786
|
-- It's used when the second argument isn't part of the result
|
|
|
787
|
+ addSizeNSD :: ExprSize NoDiscount -> ExprSize WithDiscount -> ExprSize WithDiscount
|
|
750
|
788
|
addSizeNSD TooBig _ = TooBig
|
|
751
|
789
|
addSizeNSD _ TooBig = TooBig
|
|
752
|
790
|
addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
|
|
753
|
|
- = mkSizeIs bOMB_OUT_SIZE (n1 + n2)
|
|
|
791
|
+ = mkSizeDiscount bOMB_OUT_SIZE (n1 + n2)
|
|
754
|
792
|
(xs `unionBags` ys)
|
|
755
|
793
|
d2 -- Ignore d1
|
|
756
|
794
|
|
|
|
795
|
+ -- Throw away the discount for scrutinizing the expression.
|
|
|
796
|
+ -- Used for things like `let x = rhs in body` where we only consider
|
|
|
797
|
+ -- this benefit for the body.
|
|
|
798
|
+ -- Why? `x` is visible to `body` either way, so it really should not
|
|
|
799
|
+ -- affect our inlining decision either way.
|
|
|
800
|
+ stripDiscounts :: ExprSize a -> ExprSize NoDiscount
|
|
|
801
|
+ stripDiscounts TooBig = TooBig
|
|
|
802
|
+ stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0)
|
|
|
803
|
+
|
|
757
|
804
|
-- don't count expressions such as State# RealWorld
|
|
758
|
805
|
-- exclude join points, because they can be rep-polymorphic
|
|
759
|
806
|
-- and typePrimRep will crash
|
| ... |
... |
@@ -764,7 +811,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr |
|
764
|
811
|
isZeroBitExpr _ = False
|
|
765
|
812
|
|
|
766
|
813
|
-- | Finds a nominal size of a string literal.
|
|
767
|
|
-litSize :: Literal -> Int
|
|
|
814
|
+litSize :: Literal -> PlainSize
|
|
768
|
815
|
-- Used by GHC.Core.Unfold.sizeExpr
|
|
769
|
816
|
litSize (LitNumber LitNumBigNat _) = 100
|
|
770
|
817
|
litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4)
|
| ... |
... |
@@ -775,7 +822,7 @@ litSize _other = 0 -- Must match size of nullary constructors |
|
775
|
822
|
-- Key point: if x |-> 4, then x must inline unconditionally
|
|
776
|
823
|
-- (eg via case binding)
|
|
777
|
824
|
|
|
778
|
|
-classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize
|
|
|
825
|
+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize NoDiscount
|
|
779
|
826
|
-- See Note [Conlike is interesting]
|
|
780
|
827
|
classOpSize opts cls top_args args
|
|
781
|
828
|
| isUnaryClass cls
|
| ... |
... |
@@ -798,7 +845,7 @@ classOpSize opts cls top_args args |
|
798
|
845
|
callSize
|
|
799
|
846
|
:: Int -- ^ number of value args
|
|
800
|
847
|
-> Int -- ^ number of value args that are void
|
|
801
|
|
- -> Int
|
|
|
848
|
+ -> PlainSize
|
|
802
|
849
|
callSize n_val_args voids = 10 * (1 + n_val_args - voids)
|
|
803
|
850
|
-- The 1+ is for the function itself
|
|
804
|
851
|
-- Add 1 for each non-trivial arg;
|
| ... |
... |
@@ -808,7 +855,7 @@ callSize n_val_args voids = 10 * (1 + n_val_args - voids) |
|
808
|
855
|
jumpSize
|
|
809
|
856
|
:: Int -- ^ number of value args
|
|
810
|
857
|
-> Int -- ^ number of value args that are void
|
|
811
|
|
- -> Int
|
|
|
858
|
+ -> PlainSize
|
|
812
|
859
|
jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise them
|
|
813
|
860
|
|
|
814
|
861
|
-- Old version:
|
| ... |
... |
@@ -818,7 +865,7 @@ jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise |
|
818
|
865
|
-- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a
|
|
819
|
866
|
-- better solution?
|
|
820
|
867
|
|
|
821
|
|
-funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
|
|
|
868
|
+funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize WithDiscount
|
|
822
|
869
|
-- Size for function calls where the function is not a constructor or primops
|
|
823
|
870
|
-- Note [Function applications]
|
|
824
|
871
|
funSize opts top_args fun n_val_args voids
|
| ... |
... |
@@ -844,14 +891,14 @@ funSize opts top_args fun n_val_args voids |
|
844
|
891
|
-- If the function is partially applied, show a result discount
|
|
845
|
892
|
-- XXX maybe behave like ConSize for eval'd variable
|
|
846
|
893
|
|
|
847
|
|
-conSize :: DataCon -> Int -> ExprSize
|
|
|
894
|
+conSize :: DataCon -> Int -> ExprSize WithDiscount
|
|
848
|
895
|
conSize dc n_val_args
|
|
849
|
896
|
| n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables
|
|
850
|
897
|
|
|
851
|
898
|
-- See Note [Unboxed tuple size and result discount]
|
|
852
|
899
|
| isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10
|
|
853
|
900
|
|
|
854
|
|
- | isUnaryClassDataCon dc = sizeZero
|
|
|
901
|
+ | isUnaryClassDataCon dc = withDiscount sizeZero
|
|
855
|
902
|
|
|
856
|
903
|
-- See Note [Constructor size and result discount]
|
|
857
|
904
|
| otherwise = SizeIs 10 emptyBag 10
|
| ... |
... |
@@ -948,16 +995,16 @@ that mention a literal Integer, because the float-out pass will float |
|
948
|
995
|
all those constants to top level.
|
|
949
|
996
|
-}
|
|
950
|
997
|
|
|
951
|
|
-primOpSize :: PrimOp -> Int -> ExprSize
|
|
|
998
|
+primOpSize :: PrimOp -> Int -> PlainSize
|
|
952
|
999
|
primOpSize op n_val_args
|
|
953
|
1000
|
= if primOpOutOfLine op
|
|
954
|
|
- then sizeN (op_size + n_val_args)
|
|
955
|
|
- else sizeN op_size
|
|
|
1001
|
+ then (op_size + n_val_args)
|
|
|
1002
|
+ else op_size
|
|
956
|
1003
|
where
|
|
957
|
1004
|
op_size = primOpCodeSize op
|
|
958
|
1005
|
|
|
959
|
1006
|
|
|
960
|
|
-buildSize :: ExprSize
|
|
|
1007
|
+buildSize :: ExprSize WithDiscount
|
|
961
|
1008
|
buildSize = SizeIs 0 emptyBag 40
|
|
962
|
1009
|
-- We really want to inline applications of build
|
|
963
|
1010
|
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
|
| ... |
... |
@@ -966,13 +1013,13 @@ buildSize = SizeIs 0 emptyBag 40 |
|
966
|
1013
|
-- build is saturated (it usually is). The "-2" discounts for the \c n,
|
|
967
|
1014
|
-- The "4" is rather arbitrary.
|
|
968
|
1015
|
|
|
969
|
|
-augmentSize :: ExprSize
|
|
|
1016
|
+augmentSize :: ExprSize WithDiscount
|
|
970
|
1017
|
augmentSize = SizeIs 0 emptyBag 40
|
|
971
|
1018
|
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
|
|
972
|
1019
|
-- e plus ys. The -2 accounts for the \cn
|
|
973
|
1020
|
|
|
974
|
1021
|
-- When we return a lambda, give a discount if it's used (applied)
|
|
975
|
|
-lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
|
|
|
1022
|
+lamScrutDiscount :: UnfoldingOpts -> ExprSize a -> ExprSize WithDiscount
|
|
976
|
1023
|
lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts)
|
|
977
|
1024
|
lamScrutDiscount _ TooBig = TooBig
|
|
978
|
1025
|
|
| ... |
... |
@@ -1045,18 +1092,27 @@ In a function application (f a b) |
|
1045
|
1092
|
Code for manipulating sizes
|
|
1046
|
1093
|
-}
|
|
1047
|
1094
|
|
|
|
1095
|
+-- | Does an ExprSize include an evaluation Discount?
|
|
|
1096
|
+data HasDiscount = NoDiscount | WithDiscount deriving (Eq)
|
|
|
1097
|
+
|
|
|
1098
|
+type PlainSize = Int -- Things that have a size, but not argument discount, nor scrut discount
|
|
|
1099
|
+
|
|
1048
|
1100
|
-- | The size of a candidate expression for unfolding
|
|
1049
|
|
-data ExprSize
|
|
|
1101
|
+--
|
|
|
1102
|
+-- We don't use a separate constructor without a discount field as the
|
|
|
1103
|
+-- re-allocation here as the resulting re-allocation when converting
|
|
|
1104
|
+-- between them outweights any benefit.
|
|
|
1105
|
+data ExprSize (hasDiscount :: HasDiscount)
|
|
1050
|
1106
|
= TooBig
|
|
1051
|
|
- | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found
|
|
|
1107
|
+ | SizeIs { _es_size_is :: {-# UNPACK #-} !PlainSize -- ^ Size found
|
|
1052
|
1108
|
, _es_args :: !(Bag (Id,Int))
|
|
1053
|
1109
|
-- ^ Arguments cased herein, and discount for each such
|
|
1054
|
1110
|
, _es_discount :: {-# UNPACK #-} !Int
|
|
1055
|
1111
|
-- ^ Size to subtract if result is scrutinised by a case
|
|
1056
|
|
- -- expression
|
|
|
1112
|
+ -- expression. Must be zero if `hasDiscount == NoDiscount`
|
|
1057
|
1113
|
}
|
|
1058
|
1114
|
|
|
1059
|
|
-instance Outputable ExprSize where
|
|
|
1115
|
+instance Outputable (ExprSize a) where
|
|
1060
|
1116
|
ppr TooBig = text "TooBig"
|
|
1061
|
1117
|
ppr (SizeIs a _ c) = brackets (int a <+> int c)
|
|
1062
|
1118
|
|
| ... |
... |
@@ -1065,18 +1121,28 @@ instance Outputable ExprSize where |
|
1065
|
1121
|
-- tup = (a_1, ..., a_99)
|
|
1066
|
1122
|
-- x = case tup of ...
|
|
1067
|
1123
|
--
|
|
1068
|
|
-mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
|
|
1069
|
|
-mkSizeIs max n xs d | (n - d) > max = TooBig
|
|
1070
|
|
- | otherwise = SizeIs n xs d
|
|
|
1124
|
+mkSizeDiscount :: Int -> PlainSize -> Bag (Id, Int) -> Int -> ExprSize WithDiscount
|
|
|
1125
|
+mkSizeDiscount max n xs d | (n - d) > max = TooBig
|
|
|
1126
|
+ | otherwise = SizeIs n xs d
|
|
|
1127
|
+
|
|
|
1128
|
+mkSizeNoDiscount :: Int -> PlainSize -> Bag (Id, Int) -> ExprSize NoDiscount
|
|
|
1129
|
+mkSizeNoDiscount max n xs | n > max = TooBig
|
|
|
1130
|
+ | otherwise = SizeIs n xs 0
|
|
1071
|
1131
|
|
|
1072
|
|
-maxSize :: ExprSize -> ExprSize -> ExprSize
|
|
|
1132
|
+maxSize :: ExprSize a -> ExprSize a -> ExprSize a
|
|
1073
|
1133
|
maxSize TooBig _ = TooBig
|
|
1074
|
1134
|
maxSize _ TooBig = TooBig
|
|
1075
|
1135
|
maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1
|
|
1076
|
1136
|
| otherwise = s2
|
|
|
1137
|
+withDiscount :: ExprSize NoDiscount -> ExprSize WithDiscount
|
|
|
1138
|
+withDiscount s = case s of
|
|
|
1139
|
+ TooBig -> TooBig
|
|
|
1140
|
+ SizeIs x1 x2 x3 -> SizeIs x1 x2 x3
|
|
1077
|
1141
|
|
|
1078
|
|
-sizeZero :: ExprSize
|
|
1079
|
|
-sizeN :: Int -> ExprSize
|
|
|
1142
|
+sizeZero :: ExprSize NoDiscount
|
|
|
1143
|
+sizeN :: PlainSize -> ExprSize NoDiscount
|
|
|
1144
|
+sizeND :: PlainSize -> ExprSize WithDiscount
|
|
1080
|
1145
|
|
|
1081
|
1146
|
sizeZero = SizeIs 0 emptyBag 0
|
|
1082
|
1147
|
sizeN n = SizeIs n emptyBag 0
|
|
|
1148
|
+sizeND = withDiscount . sizeN |