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