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

Commits:

8 changed files:

Changes:

  • testsuite/tests/perf/should_run/SpecTyFamRun.hs
    1 
    +{-# OPTIONS_GHC -fspecialise-aggressively #-}
    2 
    +{-# OPTIONS_GHC -fno-spec-constr #-}
    3 
    +module Main(main) where
    4 
    +
    5 
    +import SpecTyFam_Import (specMe, MaybeShowNum)
    6 
    +import GHC.Exts
    7 
    +
    8 
    +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
    9 
    +
    10 
    +{-# NOINLINE foo #-}
    11 
    +foo :: Int -> (String,Int)
    12 
    +-- We want specMe to be specialized, but not inlined
    13 
    +foo x = specMe True x
    14 
    +
    15 
    +main = print $ sum $ map (snd . foo) [1..1000 :: Int]

  • testsuite/tests/perf/should_run/SpecTyFamRun.stdout
    1 
    +500500

  • testsuite/tests/perf/should_run/SpecTyFam_Import.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +{-# LANGUAGE BangPatterns #-}
    3 
    +
    4 
    +module SpecTyFam_Import (specMe, MaybeShowNum) where
    5 
    +
    6 
    +import Data.Kind
    7 
    +
    8 
    +type family MaybeShowNum a n :: Constraint where
    9 
    +  MaybeShowNum a n = (Show a, Num n)
    10 
    +
    11 
    +{-# INLINABLE specMe #-}
    12 
    +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
    13 
    +specMe s !n = (show s, n+1 `div` 2)

  • testsuite/tests/perf/should_run/all.T
    ... ... @@ -423,3 +423,12 @@ test('ByteCodeAsm',
    423 423 
                    ],
    424 424 
                    compile_and_run,
    425 425 
                    ['-package ghc'])
    426 
    +
    427 
    +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
    428 
    +# See also #19747
    429 
    +test('SpecTyFamRun', [ grep_errmsg(r'foo')
    430 
    +                    , extra_files(['SpecTyFam_Import.hs'])
    431 
    +                    , only_ways(['optasm'])
    432 
    +                    , collect_stats('bytes allocated', 5)],
    433 
    +     multimod_compile_and_run,
    434 
    +     ['SpecTyFamRun', '-O2'])

  • testsuite/tests/simplCore/should_compile/SpecTyFam.hs
    1 
    +{-# OPTIONS_GHC -fspecialise-aggressively #-}
    2 
    +{-# OPTIONS_GHC -fno-spec-constr #-}
    3 
    +
    4 
    +module SpecTyFam(main, foo) where
    5 
    +
    6 
    +import SpecTyFam_Import (specMe, MaybeShowNum)
    7 
    +import GHC.Exts
    8 
    +
    9 
    +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
    10 
    +
    11 
    +{-# OPAQUE foo #-}
    12 
    +foo :: Int -> (String,Int)
    13 
    +foo x = specMe True x
    14 
    +
    15 
    +main = print $ sum $ map (snd . foo) [1..1000 :: Int]

  • testsuite/tests/simplCore/should_compile/SpecTyFam.stderr
    1 
    +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o )
    2 
    +
    3 
    +==================== Specialise ====================
    4 
    +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}
    5 
    +
    6 
    +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}
    7 
    +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)
    8 
    +[LclIdX,
    9 
    + Arity=4,
    10 
    + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10
    11 
    +         Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->
    12 
    +                 let {
    13 
    +                   $dNum :: Num n
    14 
    +                   [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
    15 
    +                   $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
    16 
    +                 case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]
    17 
    +specMe
    18 
    +  = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->
    19 
    +      let {
    20 
    +        $dNum :: Num n
    21 
    +        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
    22 
    +        $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
    23 
    +      case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }
    24 
    +
    25 
    +
    26 
    +
    27 
    +[2 of 2] Compiling SpecTyFam        ( SpecTyFam.hs, SpecTyFam.o )
    28 
    +
    29 
    +==================== Specialise ====================
    30 
    +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}
    31 
    +
    32 
    +Rec {
    33 
    +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}
    34 
    +$dCTuple2 :: (Show Bool, Num Int)
    35 
    +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    36 
    +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)
    37 
    +
    38 
    +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}
    39 
    +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)
    40 
    +[LclId, Arity=2]
    41 
    +$s$wspecMe
    42 
    +  = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->
    43 
    +      let {
    44 
    +        $dNum :: Num Int
    45 
    +        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
    46 
    +        $dNum = GHC.Internal.Num.$fNumInt } in
    47 
    +      case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }
    48 
    +
    49 
    +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}
    50 
    +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)
    51 
    +[LclId,
    52 
    + Arity=2,
    53 
    + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
    54 
    +         Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]
    55 
    +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }
    56 
    +end Rec }
    57 
    +
    58 
    +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}
    59 
    +foo [InlPrag=OPAQUE] :: Int -> (String, Int)
    60 
    +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]
    61 
    +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x
    62 
    +
    63 
    +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}
    64 
    +main :: State# RealWorld -> (# State# RealWorld, () #)
    65 
    +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]
    66 
    +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta
    67 
    +
    68 
    +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}
    69 
    +main :: IO ()
    70 
    +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
    71 
    +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
    72 
    +
    73 
    +
    74 
    +------ Local rules for imported ids --------
    75 
    +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
    76 
    +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe
    77 
    +
    78 
    +

  • testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +{-# LANGUAGE BangPatterns #-}
    3 
    +{-# LANGUAGE ImplicitParams #-}
    4 
    +
    5 
    +module SpecTyFam_Import (specMe, MaybeShowNum) where
    6 
    +
    7 
    +import Data.Kind
    8 
    +
    9 
    +type family MaybeShowNum a n :: Constraint where
    10 
    +  MaybeShowNum a n = (Show a, Num n)
    11 
    +
    12 
    +{-# INLINABLE specMe #-}
    13 
    +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
    14 
    +specMe s !n = (show s, n+1 `div` 2)

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -543,3 +543,10 @@ test('T25883c', normal, compile_grep_core, [''])
    543 543 
     test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
    544 544
    545 545 
     test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
    546 
    +
    547 
    +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
    548 
    +test('SpecTyFam',   [ grep_errmsg(r'\$wspecMe')
    549 
    +                    , extra_files(['SpecTyFam_Import.hs'])
    550 
    +                    , only_ways(['optasm'])],
    551 
    +     multimod_compile,
    552 
    +     ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000'])
    \ No newline at end of file

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