Simon Peyton Jones pushed to branch wip/T26548 at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/Opt/Simplify/Utils.hs
    ... ... @@ -1059,7 +1059,9 @@ interestingArg env e = go env 0 e
    1059 1059 
         go env n (Lam v e)
    1060 1060 
            | isTyVar v             = go env n e
    1061 1061 
            | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv
    1062 
    -       | otherwise             = NonTrivArg
    1062 
    +       | otherwise             = ValueArg       -- (\x.b)     is Value
    1063 
    +                                                -- Having ValueArg here is very important
    1064 
    +                                                -- for getting higher order functions to inline
    1063 1065 
         go _ _ (Case {})           = NonTrivArg
    1064 1066 
         go env n (Let b e)         = case go env' n e of
    1065 1067 
                                        ValueArg -> ValueArg
    ... ... @@ -1069,10 +1071,9 @@ interestingArg env e = go env 0 e
    1069 1071
    1070 1072 
         go_var n v
    1071 1073 
            | isConLikeId v = ValueArg   -- Experimenting with 'conlike' rather that
    1072 
    -                                    --    data constructors here
    1073 
    -                                    -- DFuns are con-like; see Note [Conlike is interesting]
    1074 
    +                                    --    data constructors here (includes DFuns)
    1074 1075 
                                         --    see (IA1) in Note [Interesting arguments]
    1075 
    -       | idArity v > n = NonTrivArg   -- Catches (eg) primops with arity but no unfolding
    1076 
    +       | idArity v > n = NonTrivArg -- Catches (eg) primops with arity but no unfolding
    1076 1077 
            | n > 0         = NonTrivArg -- Saturated or unknown call
    1077 1078 
            | otherwise  -- n==0, no value arguments; look for an interesting unfolding
    1078 1079 
            = case idUnfolding v of

  • compiler/GHC/Core/Opt/SpecConstr.hs
    ... ... @@ -2602,7 +2602,8 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
    2602 2602 
     callToPat env bndr_occs call@(Call fn args con_env)
    2603 2603 
       = do  { let in_scope = substInScopeSet (sc_subst env)
    2604 2604
    2605 
    -        ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
    2605 
    +        ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs
    2606 
    +                                   (map (const NotMarkedStrict) args)
    2606 2607 
                        -- This zip trims the args to be no longer than
    2607 2608 
                        -- the lambdas in the function definition (bndr_occs)
    2608 2609
    ... ... @@ -2639,6 +2640,15 @@ callToPat env bndr_occs call@(Call fn args con_env)
    2639 2640 
                   sanitise id = updateIdTypeAndMult expandTypeSynonyms id
    2640 2641 
                     -- See Note [Free type variables of the qvar types]
    2641 2642
    2643 
    +--         ; pprTraceM "callToPatOut" $
    2644 
    +--           vcat [ text "fn:" <+> ppr fn
    2645 
    +--                , text "args:" <+> ppr args
    2646 
    +--                , text "arg_triples:" <+> ppr arg_triples
    2647 
    +--                , text "bndr_occs:" <+> ppr bndr_occs
    2648 
    +--                , text "pat_fvs:" <+> ppr pat_fvs
    2649 
    +--                , text "qvars':" <+> ppr qvars'
    2650 
    +--                , text "pats:" <+> ppr pats ]
    2651 
    +
    2642 2652 
             -- Check for bad coercion variables: see Note [SpecConstr and casts]
    2643 2653 
             ; let bad_covars = filter isCoVar qids
    2644 2654 
             ; warnPprTrace (not (null bad_covars))
    ... ... @@ -2648,12 +2658,6 @@ callToPat env bndr_occs call@(Call fn args con_env)
    2648 2658 
               if interesting && null bad_covars
    2649 2659 
               then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
    2650 2660 
                                         , cp_strict_args = concat cbv_ids }
    2651 
    ---                  ; pprTraceM "callToPatOut" $
    2652 
    ---                    vcat [ text "fn:" <+> ppr fn
    2653 
    ---                         , text "args:" <+> ppr args
    2654 
    ---                         , text "bndr_occs:" <+> ppr bndr_occs
    2655 
    ---                         , text "pat_fvs:" <+> ppr pat_fvs
    2656 
    ---                         , text "cp_res:" <+> ppr cp_res ]
    2657 2661 
                       ; return (Just cp_res) }
    2658 2662 
               else return Nothing }
    2659 2663
    ... ... @@ -2684,9 +2688,9 @@ argToPat :: ScEnv
    2684 2688
    2685 2689 
     argToPat env in_scope val_env arg arg_occ arg_str
    2686 2690 
       = do
    2687 
    -    -- pprTraceM "argToPatIn" (ppr arg)
    2691 
    +    -- pprTraceM "argToPatIn {" (ppr arg)
    2688 2692 
         !res <- argToPat1 env in_scope val_env arg arg_occ arg_str
    2689 
    -    -- pprTraceM "argToPatOut" (ppr res)
    2693 
    +    -- pprTraceM "argToPatOut }" (ppr arg $$ ppr res)
    2690 2694 
         return res
    2691 2695
    2692 2696 
     argToPat1 :: ScEnv
    ... ... @@ -2780,7 +2784,8 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
    2780 2784 
       --    (b) we know what its value is
    2781 2785 
       -- In that case it counts as "interesting"
    2782 2786 
     argToPat1 env in_scope val_env (Var v) arg_occ arg_str
    2783 
    -  | sc_force env || specialisableArgOcc arg_occ  -- (a)
    2787 
    +  | -- pprTrace "argToPat:var" (ppr v $$ ppr is_value) $
    2788 
    +    sc_force env || specialisableArgOcc arg_occ  -- (a)
    2784 2789 
         -- See Note [Forcing specialisation], point (FS3)
    2785 2790 
       , is_value                                     -- (b)
    2786 2791 
            -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]

  • testsuite/tests/simplCore/should_compile/T26615.stderr
    ... ... @@ -2,7 +2,7 @@
    2 2
    3 3 
     ==================== Tidy Core ====================
    4 4 
     Result size of Tidy Core
    5 
    -  = {terms: 1,209, types: 1,139, coercions: 18, joins: 17/29}
    5 
    +  = {terms: 1,200, types: 1,136, coercions: 18, joins: 17/29}
    6 6
    7 7 
     -- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
    8 8 
     unArray :: forall a. Array a -> SmallArray# a
    ... ... @@ -725,7 +725,7 @@ lvl1
    725 725 
       = GHC.Internal.Control.Exception.Base.patError @LiftedRep @() lvl
    726 726
    727 727 
     Rec {
    728 
    --- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2}
    728 
    +-- RHS size: {terms: 130, types: 125, coercions: 0, joins: 1/2}
    729 729 
     T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2],
    730 730 
                                                    Occ=LoopBreaker]
    731 731 
       :: forall b a k.
    ... ... @@ -748,7 +748,6 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
    748 748 
             Empty -> GHC.Internal.Types.True;
    749 749 
             Leaf bx ds ->
    750 750 
               case ds of { L kB ds1 ->
    751 
    -          case kB of k0 { __DEFAULT ->
    752 751 
               case eqWord# bx sc of {
    753 752 
                 __DEFAULT -> GHC.Internal.Types.True;
    754 753 
                 1# ->
    ... ... @@ -780,8 +779,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
    780 779 
                         }
    781 780 
                         }; } in
    782 781 
                   jump $wlookupInArrayCont_
    783 
    -                k0 sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
    784 
    -          }
    782 
    +                kB sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
    785 783 
               }
    786 784 
               };
    787 785 
             Collision bx bx1 ->
    ... ... @@ -822,7 +820,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
    822 820 
     end Rec }
    823 821
    824 822 
     Rec {
    825 
    --- RHS size: {terms: 705, types: 732, coercions: 18, joins: 13/23}
    823 
    +-- RHS size: {terms: 699, types: 730, coercions: 18, joins: 13/23}
    826 824 
     T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
    827 825 
       :: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool
    828 826 
     [GblId[StrictWorker([~, ~, !])],
    ... ... @@ -852,7 +850,6 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
    852 850 
                              Empty -> GHC.Internal.Types.True;
    853 851 
                              Leaf bx [Occ=Once1] ds2 [Occ=Once1!] ->
    854 852 
                                case ds2 of { L kB [Occ=Once1] _ [Occ=Dead] ->
    855 
    -                           case kB of k0 [Occ=Once1] { __DEFAULT ->
    856 853 
                                joinrec {
    857 854 
                                  lookupCont_ [Occ=LoopBreakerT[5]]
    858 855 
                                    :: Eq k => Word -> k -> Int -> HashMap k a -> Bool
    ... ... @@ -980,8 +977,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
    980 977 
                                      }
    981 978 
                                      }; } in
    982 979 
                                jump lookupCont_
    983 
    -                             $dEq (GHC.Internal.Types.W# bx) k0 (GHC.Internal.Types.I# ww) ds
    984 
    -                           }
    980 
    +                             $dEq (GHC.Internal.Types.W# bx) kB (GHC.Internal.Types.I# ww) ds
    985 981 
                                };
    986 982 
                              Collision _ [Occ=Dead] _ [Occ=Dead] ->
    987 983 
                                T26615a.$wdisjointSubtrees @k @b @a $dEq ww wild ds
    ... ... @@ -992,7 +988,6 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
    992 988 
                          case ds1 of { L kA [Occ=Once2] _ [Occ=Dead] ->
    993 989 
                          case _b of wild2 [Occ=Once1] {
    994 990 
                            __DEFAULT ->
    995 
    -                         case kA of k0 [Occ=Once1] { __DEFAULT ->
    996 991 
                              joinrec {
    997 992 
                                lookupCont_ [Occ=LoopBreakerT[5]]
    998 993 
                                  :: Eq k => Word -> k -> Int -> HashMap k b -> Bool
    ... ... @@ -1116,8 +1111,11 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
    1116 1111 
                                    }
    1117 1112 
                                    }; } in
    1118 1113 
                              jump lookupCont_
    1119 
    -                           $dEq (GHC.Internal.Types.W# bx) k0 (GHC.Internal.Types.I# ww) wild2
    1120 
    -                         };
    1114 
    +                           $dEq
    1115 
    +                           (GHC.Internal.Types.W# bx)
    1116 
    +                           kA
    1117 
    +                           (GHC.Internal.Types.I# ww)
    1118 
    +                           wild2;
    1121 1119 
                            Leaf bx1 [Occ=Once1] ds3 [Occ=Once1!] ->
    1122 1120 
                              case ds3 of { L kB [Occ=Once1] _ [Occ=Dead] ->
    1123 1121 
                              case GHC.Internal.Classes.neWord
    ... ... @@ -1391,7 +1389,6 @@ T26615a.$wdisjointSubtrees
    1391 1389 
                   Empty -> GHC.Internal.Types.True;
    1392 1390 
                   Leaf bx ds2 ->
    1393 1391 
                     case ds2 of { L kB ds3 ->
    1394 
    -                case kB of k0 { __DEFAULT ->
    1395 1392 
                     join {
    1396 1393 
                       exit [Dmd=LC(S,C(1,C(1,C(1,L))))]
    1397 1394 
                         :: Word# -> k -> Word# -> Leaf k a -> Bool
    ... ... @@ -1503,8 +1500,7 @@ T26615a.$wdisjointSubtrees
    1503 1500 
                               }
    1504 1501 
                           }
    1505 1502 
                           }; } in
    1506 
    -                jump $wlookupCont_ bx k0 ww ds
    1507 
    -                }
    1503 
    +                jump $wlookupCont_ bx kB ww ds
    1508 1504 
                     };
    1509 1505 
                   Collision bx bx1 ->
    1510 1506 
                     T26615a.disjointSubtrees_$s$wdisjointSubtrees
    ... ... @@ -1516,7 +1512,6 @@ T26615a.$wdisjointSubtrees
    1516 1512 
               case ds1 of { L kA ds2 ->
    1517 1513 
               case _b of wild2 {
    1518 1514 
                 __DEFAULT ->
    1519 
    -              case kA of k0 { __DEFAULT ->
    1520 1515 
                   join {
    1521 1516 
                     exit [Dmd=LC(S,C(1,C(1,C(1,L))))]
    1522 1517 
                       :: Word# -> k -> Word# -> Leaf k b -> Bool
    ... ... @@ -1628,8 +1623,7 @@ T26615a.$wdisjointSubtrees
    1628 1623 
                             }
    1629 1624 
                         }
    1630 1625 
                         }; } in
    1631 
    -              jump $wlookupCont_ bx k0 ww wild2
    1632 
    -              };
    1626 
    +              jump $wlookupCont_ bx kA ww wild2;
    1633 1627 
                 Leaf bx1 ds3 ->
    1634 1628 
                   case ds3 of { L kB ds4 ->
    1635 1629 
                   case neWord# bx bx1 of {
    ... ... @@ -1950,7 +1944,7 @@ disjointSubtrees
    1950 1944
    1951 1945 
     ==================== Tidy Core ====================
    1952 1946 
     Result size of Tidy Core
    1953 
    -  = {terms: 614, types: 666, coercions: 18, joins: 8/14}
    1947 
    +  = {terms: 609, types: 665, coercions: 18, joins: 8/14}
    1954 1948
    1955 1949 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    1956 1950 
     T26615.$trModule2 :: GHC.Internal.Prim.Addr#
    ... ... @@ -2128,7 +2122,7 @@ $wpoly_lookupCont_
    2128 2122 
     end Rec }
    2129 2123
    2130 2124 
     Rec {
    2131 
    --- RHS size: {terms: 448, types: 507, coercions: 18, joins: 8/13}
    2125 
    +-- RHS size: {terms: 443, types: 506, coercions: 18, joins: 8/13}
    2132 2126 
     T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker]
    2133 2127 
       :: forall a b.
    2134 2128 
          GHC.Internal.Prim.Int#
    ... ... @@ -2163,11 +2157,7 @@ T26615.$s$wdisjointSubtrees
    2163 2157 
                 T26615a.Leaf bx1 ds3 ->
    2164 2158 
                   case ds3 of { T26615a.L kB ds4 ->
    2165 2159 
                   case GHC.Internal.Prim.neWord# bx bx1 of {
    2166 
    -                __DEFAULT ->
    2167 
    -                  case GHC.Internal.Classes.$fEqList_$s$c==1 kA kB of {
    2168 
    -                    False -> GHC.Internal.Types.True;
    2169 
    -                    True -> GHC.Internal.Types.False
    2170 
    -                  };
    2160 
    +                __DEFAULT -> GHC.Internal.Classes.$fEqList_$s$c/=1 kA kB;
    2171 2161 
                     1# -> GHC.Internal.Types.True
    2172 2162 
                   }
    2173 2163 
                   }

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