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

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Opt/Specialise.hs
    ... ... @@ -1713,9 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
    1713 1713 
                ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'
    1714 1714 
                      (rhs_uds2, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs $
    1715 1715 
                                                     dx_binds `consDictBinds` rhs_uds
    1716 
    -                 -- dx_binds comes from the arguments to the call,
    1717 
    -                 -- and so can mention poly_qvars but no other local binders
    1718 
    -                 spec_rhs = mkLams spec_rhs_bndrs           $
    1716 
    +                 spec_rhs = mkLams spec_rhs_bndrs $
    1719 1717 
                                 wrapDictBindsE inner_dumped_dbs rhs_body'
    1720 1718 
                      rule_rhs_args = spec_bndrs
    1721 1719
    ... ... @@ -1784,8 +1782,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
    1784 1782 
                                            , text "rule_act" <+> ppr rule_act
    1785 1783 
                                            ]
    1786 1784
    1787 
    ---           ; pprTrace "spec_call: rule" (vcat [ -- text "poly_qvars" <+> ppr poly_qvars
    1788 
    ---                                                text "rule_bndrs" <+> ppr rule_bndrs
    1785 
    +--           ; pprTrace "spec_call: rule" (vcat [ text "rule_bndrs" <+> ppr rule_bndrs
    1789 1786 
     --                                              , text "rule_lhs_args" <+> ppr rule_lhs_args
    1790 1787 
     --                                              , text "all_call_args" <+> ppr all_call_args
    1791 1788 
     --                                              , ppr spec_rule ]) $
    ... ... @@ -2611,6 +2608,14 @@ specHeader subst (bndr:bndrs) (UnspecType : args)
    2611 2608 
     -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
    2612 2609 
     -- the nitty-gritty), as a LHS rule and unfolding details.
    2613 2610 
     specHeader subst (bndr:bndrs) (SpecDict dict_arg : args)
    2611 
    +  | let in_scope = getInScopeVars (substInScopeSet subst)
    2612 
    +        bad_dict_fv v = isLocalVar v && not (v `elemVarSet` in_scope)
    2613 
    +  , not $ isEmptyVarSet $ exprSomeFreeVars bad_dict_fv dict_arg
    2614 
    +  = -- Do not specialise if `dict_arg` has any any free vars that are /not/ in scope
    2615 
    +    -- See Note [Weird special case for SpecDict]
    2616 
    +    specHeader mod subst (bndr:bndrs) (UnspecArg : args)
    2617 
    +
    2618 
    +  | otherwise
    2614 2619 
       = do { -- Make up a fresh binder to use in the RULE
    2615 2620 
              -- It might turn into a dict binding (via bindAuxiliaryDict) which we
    2616 2621 
              -- then float, so we use cloneIdBndr to get a completely fresh binder
    ... ... @@ -2886,13 +2891,15 @@ We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that
    2886 2891 
     is a lot of hard work for a very strange case.
    2887 2892
    2888 2893 
     So we simply refrain from specialising in this case; hence the guard
    2889 
    -   allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
    2890 
    -in the SpecDict cased of specHeader.
    2891 
    -
    2892 
    -How did this strange polymorphic mkD arise in the first place?
    2893 
    -From GHC.Core.Opt.Utils.abstractFloats, which was abstracting
    2894 
    -over too many type variables. But that too is now fixed;
    2895 
    -see Note [Which type variables to abstract over] in that module.
    2894 
    +   not $ isEmptyVarSet $ exprSomeFreeVars bad_dict_fv dict_arg
    2895 
    +in the SpecDict case of `specHeader`.
    2896 
    +
    2897 
    +How did this strange polymorphic mkD arise in the first place?  From
    2898 
    +GHC.Core.Opt.Utils.abstractFloats, which was abstracting over too many type
    2899 
    +variables. But that too is now fixed; see Note [Which type variables to abstract
    2900 
    +over] in that module.  So we don't actually have a Haskell source program that
    2901 
    +triggers it (see #27629) -- only test T27629 that uses a plugin to inject a strange
    2902 
    +definition.
    2896 2903 
     -}
    2897 2904
    2898 2905 
     instance Outputable DictBind where

  • testsuite/tests/simplCore/should_compile/Makefile
    ... ... @@ -3,6 +3,12 @@ include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 5
    6 
    +# T27629 runs a plugin that injects a Core binding
    7 
    +# that made the specialiser crash
    8 
    +T27629:
    9 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) --make -package ghc -dynamic-too -c T27629Plugin.hs
    10 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O -fpolymorphic-specialisation -dcore-lint T27629.hs
    11 
    +
    6 12 
     # T18815 should not have a non-recursive join-point for 'go'
    7 13 
     # Previously we ended up with
    8 14 
     #      join {go_sPI w_sQ3 = case w_sQ3 of { GHC.Types.I# ww1_sQ6 ->

  • testsuite/tests/simplCore/should_compile/T27629.hs
    1 
    +{-# LANGUAGE AllowAmbiguousTypes #-}
    2 
    +{-# OPTIONS_GHC -fplugin=T27629Plugin #-}
    3 
    +
    4 
    +-- The plugin rewrites 'poly' to the example of
    5 
    +-- Note [Weird special case for SpecDict]:
    6 
    +--
    7 
    +--   poly = /\x. \t. split @T (mkD @x MkT) [t]
    8 
    +--
    9 
    +-- where mkD :: forall a. T -> C T is a new top-level binding
    10 
    +-- (mkD = /\a. \_. $fCT), so the tyvar x is free in the dictionary
    11 
    +-- *expression* but not in its *type* (C T).
    12 
    +module T27629 (poly, split, T (..), C (..)) where
    13 
    +
    14 
    +import Data.Kind (Type)
    15 
    +
    16 
    +data T = MkT
    17 
    +
    18 
    +class C b where
    19 
    +  meth :: b -> b
    20 
    +
    21 
    +instance C T where
    22 
    +  meth x = x
    23 
    +
    24 
    +split :: C b => [b] -> [b]
    25 
    +split [] = []
    26 
    +split (x : xs) = meth x : split xs
    27 
    +
    28 
    +poly :: forall (x :: Type). T -> [T]
    29 
    +poly t = [t]

  • testsuite/tests/simplCore/should_compile/T27629.stderr
    1 
    +ReproPlugin: injected weird SpecDict call into poly

  • testsuite/tests/simplCore/should_compile/T27629Plugin.hs
    1 
    +-- Injects the example of Note [Weird special case for SpecDict] in
    2 
    +-- GHC.Core.Opt.Specialise, which cannot be written in source Haskell:
    3 
    +-- a call whose dictionary argument mentions a type variable that is
    4 
    +-- free in the dictionary expression but not in its type.
    5 
    +--
    6 
    +-- Runs before the main Core pipeline (in particular before the
    7 
    +-- Specialiser). It adds
    8 
    +--
    9 
    +--   mkD :: forall a. T -> C T    {-# NOINLINE mkD #-}
    10 
    +--   mkD = /\a. \_. $fCT
    11 
    +--
    12 
    +-- and rewrites   poly = /\x. \t. [t]
    13 
    +-- to             poly = /\x. \t. split @T (mkD @x MkT) [t]
    14 
    +{-# LANGUAGE CPP #-}
    15 
    +module T27629Plugin (plugin) where
    16 
    +
    17 
    +import GHC.Core.Make (mkCoreApps, mkListExpr)
    18 
    +import GHC.Core.Predicate (getClassPredTys_maybe)
    19 
    +import GHC.Plugins
    20 
    +#if __GLASGOW_HASKELL__ >= 1000
    21 
    +import GHC.Types.InlinePragma (neverInlinePragma)
    22 
    +#else
    23 
    +import GHC.Types.Basic (neverInlinePragma)
    24 
    +#endif
    25 
    +
    26 
    +plugin :: Plugin
    27 
    +plugin =
    28 
    +  defaultPlugin
    29 
    +    { installCoreToDos = \_ todos ->
    30 
    +        return (CoreDoPluginPass "inject-weird-specdict" pass : todos)
    31 
    +    , pluginRecompile = purePlugin
    32 
    +    }
    33 
    +
    34 
    +pass :: ModGuts -> CoreM ModGuts
    35 
    +pass guts = do
    36 
    +  let binds = mg_binds guts
    37 
    +
    38 
    +      dfun = case [b | b <- bindersOfBinds binds, isDFunId b] of
    39 
    +        (b : _) -> b
    40 
    +        [] -> panic "ReproPlugin: no dfun binding in module"
    41 
    +
    42 
    +      dictTy = idType dfun -- C T
    43 
    +      tyT = case getClassPredTys_maybe dictTy of
    44 
    +        Just (_cls, [t]) -> t
    45 
    +        _ -> panic "ReproPlugin: dfun type is not C T"
    46 
    +
    47 
    +      mkTCon = case tyConDataCons (tyConAppTyCon tyT) of
    48 
    +        (dc : _) -> dataConWorkId dc
    49 
    +        [] -> panic "ReproPlugin: T has no data constructors"
    50 
    +
    51 
    +      findTopId nm =
    52 
    +        case [b | b <- bindersOfBinds binds, occNameString (getOccName b) == nm] of
    53 
    +          (b : _) -> b
    54 
    +          [] -> panic ("ReproPlugin: no top-level binding " ++ nm)
    55 
    +
    56 
    +      splitId = findTopId "split"
    57 
    +      polyId = findTopId "poly"
    58 
    +
    59 
    +  uMkD <- getUniqueM
    60 
    +  uTv <- getUniqueM
    61 
    +  uWild <- getUniqueM
    62 
    +
    63 
    +  let aTv = mkTyVar (mkSystemName uTv (mkTyVarOcc "a")) liftedTypeKind
    64 
    +      mkDTy = mkSpecForAllTys [aTv] (mkFunctionType ManyTy tyT dictTy)
    65 
    +      mkDId =
    66 
    +        setInlinePragma
    67 
    +          (mkExportedVanillaId (mkSystemName uMkD (mkVarOcc "mkD")) mkDTy)
    68 
    +          neverInlinePragma
    69 
    +      wild = mkSysLocal (fsLit "eta") uWild ManyTy tyT
    70 
    +      mkDBind = NonRec mkDId (mkLams [aTv, wild] (Var dfun))
    71 
    +
    72 
    +      rewritePoly rhs
    73 
    +        | (bndrs, _body) <- collectBinders rhs
    74 
    +        , (x : _) <- reverse (filter isTyVar bndrs)
    75 
    +        , (t : _) <- filter isId bndrs
    76 
    +        = mkLams bndrs $
    77 
    +            mkCoreApps
    78 
    +              (Var splitId)
    79 
    +              [ Type tyT
    80 
    +              , mkCoreApps (Var mkDId) [Type (mkTyVarTy x), Var mkTCon]
    81 
    +              , mkListExpr tyT [Var t]
    82 
    +              ]
    83 
    +        | otherwise =
    84 
    +            pprPanic "ReproPlugin: unexpected shape of poly" (ppr rhs)
    85 
    +
    86 
    +      go (b, rhs)
    87 
    +        | b == polyId = (b, rewritePoly rhs)
    88 
    +        | otherwise = (b, rhs)
    89 
    +
    90 
    +      -- One top-level Rec, so bind order is irrelevant.
    91 
    +      binds' = [Rec (map go (flattenBinds binds) ++ flattenBinds [mkDBind])]
    92 
    +
    93 
    +  putMsgS "ReproPlugin: injected weird SpecDict call into poly"
    94 
    +  return guts {mg_binds = binds'}

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -611,3 +611,4 @@ test('T27296', [], makefile_test, ['T27296'])
    611 611 
     test('T27296b', [], makefile_test, ['T27296b'])
    612 612 
     test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
    613 613 
     test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
    614 
    +test('T27629', only_ways(['optasm']), makefile_test, ['T27629'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/eed2f9cccb80bddaa047bab6f754b4912da68954 at 1788430657