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

Commits:

3 changed files:

Changes:

  • compiler/GHC/Core/Opt/SetLevels.hs
    ... ... @@ -91,6 +91,7 @@ import GHC.Core.Utils
    91 91 
     import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr )
    92 92 
     import GHC.Core.FVs     -- all of it
    93 93 
     import GHC.Core.Subst
    94 
    +import GHC.Core.TyCo.Subst( lookupTyVar )
    94 95 
     import GHC.Core.Make    ( sortQuantVars )
    95 96 
     import GHC.Core.Type    ( Type, tyCoVarsOfType
    96 97 
                             , mightBeUnliftedType, closeOverKindsDSet
    ... ... @@ -466,8 +467,8 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
    466 467 
         ty' = substTyUnchecked (le_subst env) ty
    467 468
    468 469 
         incd_lvl = incMinorLvl (le_ctxt_lvl env)
    469 
    -    dest_lvl = maxFvLevel (const True) env scrut_fvs
    470 
    -            -- Don't abstract over type variables, hence const True
    470 
    +    dest_lvl = maxFvLevel includeTyVars env scrut_fvs
    471 
    +            -- Don't abstract over type variables, hence includeTyVars
    471 472
    472 473 
         lvl_alt alts_env (AnnAlt con bs rhs)
    473 474 
           = do { rhs' <- lvlMFE new_env True rhs
    ... ... @@ -719,8 +720,11 @@ hasFreeJoin :: LevelEnv -> DVarSet -> Bool
    719 720 
     -- (In the latter case it won't be a join point any more.)
    720 721 
     -- Not treating top-level ones specially had a massive effect
    721 722 
     -- on nofib/minimax/Prog.prog
    722 
    -hasFreeJoin env fvs
    723 
    -  = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
    723 
    +hasFreeJoin env fvs = anyDVarSet bad_join fvs
    724 
    +  where
    725 
    +    bad_join v = isJoinId v &&
    726 
    +                 maxIn True env v tOP_LEVEL /= tOP_LEVEL
    727 
    +
    724 728
    725 729 
     {- Note [Saving work]
    726 730 
     ~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1607,10 +1611,10 @@ destLevel env fvs fvs_ty is_function is_bot
    1607 1611
    1608 1612 
       | otherwise = max_fv_id_level
    1609 1613 
       where
    1610 
    -    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
    1611 
    -                                              -- tyvars will be abstracted
    1614 
    +    max_fv_id_level = maxFvLevel idsOnly env fvs -- Max over Ids only; the
    1615 
    +                                                 -- tyvars will be abstracted
    1612 1616
    1613 
    -    as_far_as_poss = maxFvLevel' isId env fvs_ty
    1617 
    +    as_far_as_poss = maxFvLevel' idsOnly env fvs_ty
    1614 1618 
                          -- See Note [Floating and kind casts]
    1615 1619
    1616 1620 
     {- Note [Floating and kind casts]
    ... ... @@ -1768,28 +1772,47 @@ extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
    1768 1772 
            , le_env     = add_id id_env (case_bndr, scrut_var) }
    1769 1773 
     extendCaseBndrEnv env _ _ = env
    1770 1774
    1771 
    -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
    1772 
    -maxFvLevel max_me env var_set
    1773 
    -  = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
    1775 
    +includeTyVars, idsOnly :: Bool
    1776 
    +idsOnly       = False
    1777 
    +includeTyVars = True
    1778 
    +
    1779 
    +maxFvLevel :: Bool -> LevelEnv -> DVarSet -> Level
    1780 
    +maxFvLevel include_tyvars env var_set
    1781 
    +  = nonDetStrictFoldDVarSet (maxIn include_tyvars env) tOP_LEVEL var_set
    1774 1782 
         -- It's OK to use a non-deterministic fold here because maxIn commutes.
    1775 1783
    1776 
    -maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
    1784 
    +maxFvLevel' :: Bool -> LevelEnv -> TyCoVarSet -> Level
    1777 1785 
     -- Same but for TyCoVarSet
    1778 
    -maxFvLevel' max_me env var_set
    1779 
    -  = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
    1786 
    +maxFvLevel' include_tyvars env var_set
    1787 
    +  = nonDetStrictFoldUniqSet (maxIn include_tyvars env) tOP_LEVEL var_set
    1780 1788 
         -- It's OK to use a non-deterministic fold here because maxIn commutes.
    1781 1789
    1782 
    -maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
    1783 
    -maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
    1790 
    +maxIn :: Bool -> LevelEnv -> InVar -> Level -> Level
    1791 
    +-- True <=> include tyvars
    1792 
    +maxIn include_tyvars env@(LE { le_subst = subst, le_env = id_env }) in_var lvl
    1793 
    +  | isId in_var
    1784 1794 
       = case lookupVarEnv id_env in_var of
    1795 
    +      Nothing            -> maxOut env in_var lvl
    1785 1796 
           Just (abs_vars, _) -> foldr max_out lvl abs_vars
    1786 
    -      Nothing            -> max_out in_var lvl
    1787 
    -  where
    1788 
    -    max_out out_var lvl
    1789 
    -        | max_me out_var = case lookupVarEnv lvl_env out_var of
    1790 
    -                                Just lvl' -> maxLvl lvl' lvl
    1791 
    -                                Nothing   -> lvl
    1792 
    -        | otherwise = lvl       -- Ignore some vars depending on max_me
    1797 
    +          where
    1798 
    +            max_out out_var lvl
    1799 
    +              | isTyVar out_var && not include_tyvars
    1800 
    +                          = lvl
    1801 
    +              | otherwise = maxOut env out_var lvl
    1802 
    +
    1803 
    +  | include_tyvars -- TyVars
    1804 
    +  = case lookupTyVar subst in_var of
    1805 
    +      Just ty -> nonDetStrictFoldVarSet (maxOut env) lvl (tyCoVarsOfType ty)
    1806 
    +      Nothing -> maxOut env in_var lvl
    1807 
    +
    1808 
    +  | otherwise      -- Ignore free tyvars
    1809 
    +  = lvl
    1810 
    +
    1811 
    +maxOut :: LevelEnv -> OutVar -> Level -> Level
    1812 
    +maxOut (LE { le_lvl_env = lvl_env }) out_var lvl
    1813 
    +  = case lookupVarEnv lvl_env out_var of
    1814 
    +       Just lvl' -> maxLvl lvl' lvl
    1815 
    +       Nothing   -> lvl
    1793 1816
    1794 1817 
     lookupVar :: LevelEnv -> Id -> LevelledExpr
    1795 1818 
     lookupVar le v = case lookupVarEnv (le_env le) v of

  • testsuite/tests/simplCore/should_compile/T26681.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +{-# LANGUAGE DataKinds #-}
    3 
    +{-# LANGUAGE GADTs #-}
    4 
    +{-# LANGUAGE PolyKinds #-}
    5 
    +{-# LANGUAGE ScopedTypeVariables #-}
    6 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    7 
    +{-# LANGUAGE TypeApplications #-}
    8 
    +{-# LANGUAGE TypeFamilies #-}
    9 
    +{-# LANGUAGE TypeOperators #-}
    10 
    +
    11 
    +module T26681 where
    12 
    +
    13 
    +import Data.Kind (Type)
    14 
    +import Data.Type.Equality
    15 
    +import GHC.TypeLits
    16 
    +import qualified Unsafe.Coerce
    17 
    +
    18 
    +
    19 
    +{-# NOINLINE unsafeCoerceRefl #-}
    20 
    +unsafeCoerceRefl :: a :~: b
    21 
    +unsafeCoerceRefl = Unsafe.Coerce.unsafeCoerce Refl
    22 
    +
    23 
    +type family MapJust l where
    24 
    +  MapJust '[] = '[]
    25 
    +  MapJust (x : xs) = Just x : MapJust xs
    26 
    +
    27 
    +type family Tail l where
    28 
    +  Tail (_ : xs) = xs
    29 
    +
    30 
    +lemMapJustCons :: MapJust sh :~: Just n : sh' -> sh :~: n : Tail sh
    31 
    +lemMapJustCons Refl = unsafeCoerceRefl
    32 
    +
    33 
    +
    34 
    +type ListX :: [Maybe Nat] -> (Maybe Nat -> Type) -> Type
    35 
    +data ListX sh f where
    36 
    +  ConsX :: !(f n) -> ListX (n : sh) f
    37 
    +
    38 
    +
    39 
    +data JustN n where
    40 
    +  JustN :: JustN (Just n)
    41 
    +
    42 
    +data UnconsListSRes f sh1 = forall n sh. (n : sh ~ sh1) => UnconsListSRes
    43 
    +
    44 
    +listsUncons :: forall sh1 f. ListX (MapJust sh1) JustN -> UnconsListSRes f sh1
    45 
    +listsUncons (ConsX JustN)
    46 
    +  | Refl <- lemMapJustCons @sh1 Refl
    47 
    +  = UnconsListSRes

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -563,3 +563,4 @@ test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uni
    563 563 
     test('T26116', normal, compile, ['-O -ddump-rules'])
    564 564 
     test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    565 565 
     test('T26349',  normal, compile, ['-O -ddump-rules'])
    566 
    +test('T26681',  normal, compile, ['-O'])

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