Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Core/Unfold.hs
    ... ... @@ -62,7 +62,6 @@ import GHC.Data.Bag
    62 62
    63 63 
     import GHC.Utils.Misc
    64 64 
     import GHC.Utils.Outputable
    65 
    -import GHC.Utils.Panic.Plain (assert)
    66 65
    67 66 
     import qualified Data.ByteString as BS
    68 67 
     import Data.List.NonEmpty (nonEmpty)
    ... ... @@ -558,7 +557,6 @@ uncondInlineJoin bndrs body
    558 557 
         go_arg (Var f)       = Just $! f `notElem` bndrs
    559 558 
         go_arg _             = Nothing
    560 559
    561 
    -
    562 560 
     sizeExpr :: UnfoldingOpts
    563 561 
              -> Int             -- Bomb out if it gets bigger than this
    564 562 
              -> [Id]            -- Arguments; we're interested in which of these
    ... ... @@ -571,44 +569,51 @@ sizeExpr :: UnfoldingOpts
    571 569 
     -- Forcing bOMB_OUT_SIZE early prevents repeated
    572 570 
     -- unboxing of the Int argument.
    573 571 
     sizeExpr opts !bOMB_OUT_SIZE top_args expr
    574 
    -  = size_up sizeZero expr
    572 
    +  = size_up 0 expr
    575 573 
       where
    576 574 
         -- (size_up s e) returns `s` plus the size of `e`
    577 
    -    size_up :: (ExprSize NoDiscount) -> CoreExpr -> ExprSize WithDiscount
    578 
    -    size_up s (Cast e _)  = size_up s e
    579 
    -    size_up s (Tick _ e)  = size_up s e
    580 
    -    size_up s (Type _)    = withDiscount s           -- Types cost nothing
    581 
    -    size_up s (Coercion _)  = withDiscount s
    582 
    -    size_up s (Lit lit)  = withDiscount $ s `addSizeN` litSize lit
    583 
    -    size_up s (Var f)    | isZeroBitId f = withDiscount s
    575 
    +    size_up :: Int -> CoreExpr -> ExprSize WithDiscount
    576 
    +    size_up acc_size (Cast e _)  = size_up acc_size e
    577 
    +    size_up acc_size (Tick _ e)  = size_up acc_size e
    578 
    +    size_up acc_size (Type _)    = mkSizeDiscount bOMB_OUT_SIZE acc_size emptyBag 0           -- Types cost nothing
    579 
    +    size_up acc_size (Coercion _)  = mkSizeDiscount bOMB_OUT_SIZE acc_size emptyBag 0
    580 
    +    size_up acc_size (Lit lit)  = (mkSizeDiscount bOMB_OUT_SIZE acc_size emptyBag 0) `addSizeND` litSize lit
    581 
    +    size_up acc_size (Var f)    | isZeroBitId f = mkSizeDiscount bOMB_OUT_SIZE acc_size emptyBag 0
    584 582 
                             -- Make sure we get constructor discounts even
    585 583 
                             -- on nullary constructors
    586 
    -                        | otherwise       = size_up_call s f [] 0
    587 
    -
    588 
    -    size_up s (App fun arg)
    589 
    -      | isTyCoArg arg = size_up s fun
    590 
    -      | otherwise     =  size_up_app (stripDiscounts $ size_up s arg)
    591 
    -                                     fun [arg] (if isZeroBitExpr arg then 1 else 0)
    592 
    -
    593 
    -    size_up s (Lam b e)
    594 
    -      | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e)
    595 
    -      | otherwise = size_up s e
    596 
    -
    597 
    -    size_up s (Let (NonRec binder rhs) body)
    598 
    -      = let rhs_s = size_up_let s (binder, rhs)
    599 
    -        in size_up (stripDiscounts $ rhs_s) body
    600 
    -
    601 
    -
    602 
    -    size_up s (Let (Rec pairs) body)
    603 
    -      = size_up ((foldr (flip (size_up_let)) s pairs))
    604 
    -                body
    605 
    -
    606 
    -    size_up s (Case e _ _ alts) = case nonEmpty alts of
    607 
    -      Nothing -> size_up s e    -- case e of {} never returns, so take size of scrutinee
    584 
    +                        | otherwise       = size_up_call acc_size emptyBag f [] 0
    585 
    +
    586 
    +    size_up acc_size (App fun arg)
    587 
    +      | isTyCoArg arg = size_up acc_size fun
    588 
    +      | otherwise     = case size_up acc_size arg of
    589 
    +          TooBig -> TooBig
    590 
    +          SizeIs acc_size' acc_args' _d -> size_up_app  acc_size' acc_args'
    591 
    +                                                        fun [arg] (if isZeroBitExpr arg then 1 else 0)
    592 
    +
    593 
    +    size_up acc_size (Lam b e)
    594 
    +      | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (acc_size+10) e)
    595 
    +      | otherwise = size_up acc_size e
    596 
    +
    597 
    +    size_up acc_size (Let (NonRec binder rhs) body)
    598 
    +      = case size_up_let acc_size emptyBag (binder, rhs) of
    599 
    +          TooBig -> TooBig
    600 
    +          SizeIs acc_size' acc_args' _d -> size_up acc_size' body `addSizeB` acc_args'
    601 
    +
    602 
    +    size_up acc_size (Let (Rec pairs) body)
    603 
    +      = do_pairs acc_size emptyBag pairs
    604 
    +      where
    605 
    +        do_pairs acc_size acc_args [] = size_up acc_size body `addSizeB` acc_args
    606 
    +        do_pairs acc_size acc_args (pair:pairs) =
    607 
    +          case size_up_let acc_size acc_args pair of
    608 
    +            TooBig -> TooBig
    609 
    +            SizeIs acc_size' acc_args' _d -> do_pairs acc_size' acc_args' pairs
    610 
    +
    611 
    +    size_up acc_size (Case e _ _ alts) = case nonEmpty alts of
    612 
    +      Nothing -> size_up acc_size e    -- case e of {} never returns, so take size of scrutinee
    608 613 
           Just alts
    609 614 
             | Just v <- is_top_arg e -> -- We are scrutinising an argument variable
    610 615 
               let
    611 
    -            alt_sizes = NE.map (size_up_alt s) alts
    616 
    +            alt_sizes = NE.map (size_up_alt acc_size) alts
    612 617
    613 618 
                       -- alts_size tries to compute a good discount for
    614 619 
                       -- the case when we are scrutinising an argument variable
    ... ... @@ -630,14 +635,14 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
    630 635
    631 636 
                 alts_size tot_size _ = tot_size
    632 637 
               in
    633 
    -          s `addSizeNSD`  alts_size (foldr1 addAltSize alt_sizes)  -- alts is non-empty
    638 
    +          mkSizeNoDiscount bOMB_OUT_SIZE acc_size emptyBag `addSizeNSD`  alts_size (foldr1 addAltSize alt_sizes)  -- alts is non-empty
    634 639 
                                         (foldr1 maxSize    alt_sizes)
    635 640 
                     -- Good to inline if an arg is scrutinised, because
    636 641 
                     -- that may eliminate allocation in the caller
    637 642 
                     -- And it eliminates the case itself
    638 643
    639 
    -        | otherwise -> foldr  (addAltSize . size_up_alt s)
    640 
    -                              (size_up (s `addSizeN` case_size) e)
    644 
    +        | otherwise -> foldr  (addAltSize . (size_up_alt acc_size))
    645 
    +                              (size_up (acc_size + case_size) e)
    641 646 
                                   alts
    642 647
    643 648 
             where
    ... ... @@ -683,35 +688,38 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
    683 688 
                   | otherwise
    684 689 
                     = False
    685 690
    686 
    -    size_up_let :: ExprSize NoDiscount -> (Id, CoreExpr) -> ExprSize NoDiscount
    687 
    -    size_up_let s (bndr, rhs)
    691 
    +    size_up_let :: Int -> Bag (Id,Int) -> (Id, CoreExpr) -> ExprSize NoDiscount
    692 
    +    size_up_let acc_size acc_args (bndr, rhs)
    688 693 
           | JoinPoint join_arity <- idJoinPointHood bndr
    689 694 
             -- Skip arguments to join point
    690 695 
           , (_bndrs, join_rhs) <- collectNBinders join_arity rhs
    691 
    -      = stripDiscounts $ size_up s join_rhs
    696 
    +      = (stripDiscounts $ size_up acc_size join_rhs) `addSizeB` acc_args
    692 697 
           | otherwise
    693 
    -      = stripDiscounts $ size_up (s `addSizeN` size_up_alloc bndr) rhs
    698 
    +      = (stripDiscounts $ size_up (acc_size + size_up_alloc bndr) rhs) `addSizeB` acc_args
    694 699
    695 700 
         ------------
    696 701 
         -- size_up_app is used when there's ONE OR MORE value args
    697 
    -    size_up_app :: ExprSize NoDiscount -> CoreExpr -> [CoreExpr] -> Int -> ExprSize WithDiscount
    698 
    -    size_up_app s (App fun arg) args voids
    699 
    -        | isTyCoArg arg                  = size_up_app s fun args voids
    700 
    -        | isZeroBitExpr arg              = size_up_app s fun (arg:args) (voids + 1)
    701 
    -        | otherwise                      =  let arg_size = stripDiscounts $ size_up s arg
    702 
    -                                            in size_up_app arg_size fun (arg:args) voids
    703 
    -    size_up_app s (Var fun)     args voids = size_up_call s fun args voids
    704 
    -    size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids
    705 
    -    size_up_app s (Cast expr _) args voids = size_up_app s expr args voids
    706 
    -    size_up_app s other         args voids = size_up (s `addSizeN` callSize (length args) voids) other
    702 
    +    size_up_app :: Int -> Bag (Id,Int) -> CoreExpr -> [CoreExpr] -> Int -> ExprSize WithDiscount
    703 
    +    size_up_app acc_size acc_args (App fun arg) args voids
    704 
    +        | isTyCoArg arg                  = size_up_app acc_size acc_args fun args voids
    705 
    +        | isZeroBitExpr arg              = size_up_app acc_size acc_args fun (arg:args) (voids + 1)
    706 
    +        | otherwise                      =  case size_up acc_size arg of
    707 
    +                                              TooBig -> TooBig
    708 
    +                                              SizeIs acc_size' acc_args' _ ->
    709 
    +                                                  size_up_app acc_size' acc_args' fun (arg:args) voids
    710 
    +                                                      `addSizeB` acc_args
    711 
    +    size_up_app acc_size acc_args (Var fun)     args voids = size_up_call acc_size acc_args fun args voids
    712 
    +    size_up_app acc_size acc_args (Tick _ expr) args voids = size_up_app acc_size acc_args expr args voids
    713 
    +    size_up_app acc_size acc_args (Cast expr _) args voids = size_up_app acc_size acc_args expr args voids
    714 
    +    size_up_app acc_size acc_args other         args voids = size_up (acc_size + callSize (length args) voids) other `addSizeB` acc_args
    707 715
    708 716 
            -- if the lhs is not an App or a Var, or an invisible thing like a
    709 717 
            -- Tick or Cast, then we should charge for a complete call plus the
    710 718 
            -- size of the lhs itself.
    711 719
    712 720 
         ------------
    713 
    -    size_up_call :: ExprSize NoDiscount -> Id -> [CoreExpr] -> Int -> ExprSize WithDiscount
    714 
    -    size_up_call !s fun val_args voids
    721 
    +    size_up_call :: Int -> Bag (Id,Int) -> Id -> [CoreExpr] -> Int -> ExprSize WithDiscount
    722 
    +    size_up_call acc_size acc_args fun val_args voids
    715 723 
            = let !n_args = length val_args
    716 724 
                  call_size = case idDetails fun of
    717 725 
                                 FCallId _                     -> withDiscount $ sizeN (callSize n_args voids)
    ... ... @@ -721,18 +729,18 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
    721 729 
                                 _ | fun `hasKey` buildIdKey   -> buildSize
    722 730 
                                   | fun `hasKey` augmentIdKey -> augmentSize
    723 731 
                                   | otherwise                 -> funSize opts top_args fun n_args voids
    724 
    -          in s `addSizeNSD` call_size
    732 
    +          in mkSizeNoDiscount bOMB_OUT_SIZE acc_size acc_args `addSizeNSD` call_size
    725 733
    726 734 
         ------------
    727 
    -    -- size_up_alt returns on the alternatives size, not counting the accumulated
    735 
    +    -- size_up_alt returns only the alternatives size, not counting the accumulated
    728 736 
         -- size passed in unless we reach TooBig. This is to facility better discount
    729 737 
         -- calculation based on the size of only the alternative.
    730 
    -    size_up_alt TooBig _ = TooBig
    731 
    -    size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) =
    732 
    -        size_up (sizeN s) rhs
    738 
    +    -- size_up_alt acc_size acc_args = TooBig
    739 
    +    size_up_alt acc_size (Alt _con _bndrs rhs) =
    740 
    +        size_up acc_size rhs
    733 741 
                     -- Why add and then subtract s?
    734 742 
                     -- If the expression large enough this will ensure we bomb out early.
    735 
    -                `addSizeND` (10 -s)
    743 
    +                `addSizeND` (10 -acc_size)
    736 744
    737 745 
             -- Don't charge for args, so that wrappers look cheap
    738 746 
             -- (See comments about wrappers with Case)
    ... ... @@ -758,10 +766,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
    758 766 
         addSizeND TooBig          _  = TooBig
    759 767 
         addSizeND (SizeIs n xs d) m  = mkSizeDiscount bOMB_OUT_SIZE (n + m) xs d
    760 768
    761 
    -    addSizeN :: ExprSize NoDiscount -> Int -> ExprSize NoDiscount
    762 
    -    addSizeN TooBig          _  = TooBig
    763 
    -    addSizeN (SizeIs n xs _d) m  = mkSizeNoDiscount bOMB_OUT_SIZE (n + m) xs
    764 
    -
    769 
    +    addSizeB :: ExprSize a -> Bag (Id,Int) -> ExprSize a
    770 
    +    addSizeB TooBig _ = TooBig
    771 
    +    addSizeB (SizeIs sz bg1 dc) bg2 = SizeIs sz (bg1 `unionBags` bg2) dc
    765 772 
             -- addAltSize is used to add the sizes of case alternatives
    766 773 
         addAltSize TooBig            _      = TooBig
    767 774 
         addAltSize _                 TooBig = TooBig

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help