diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-02-02 10:06:11 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2021-03-07 17:01:40 -0500 |
commit | 3e082f8ff5ea2f42c5e6430094683b26b5818fb8 (patch) | |
tree | 4c85427ff40740b654cf1911a20a3a478a9fb754 /testsuite/tests/typecheck/should_run | |
parent | cf65cf16c89414273c4f6b2d090d4b2fffb90759 (diff) | |
download | haskell-3e082f8ff5ea2f42c5e6430094683b26b5818fb8.tar.gz |
Implement BoxedRep proposalwip/boxed-rep
This implements the BoxedRep proposal, refactoring the `RuntimeRep`
hierarchy from:
```haskell
data RuntimeRep = LiftedPtrRep | UnliftedPtrRep | ...
```
to
```haskell
data RuntimeRep = BoxedRep Levity | ...
data Levity = Lifted | Unlifted
```
Updates binary, haddock submodules.
Closes #17526.
Metric Increase:
T12545
Diffstat (limited to 'testsuite/tests/typecheck/should_run')
11 files changed, 49 insertions, 13 deletions
diff --git a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs index d57d2e1499..82553b4ff2 100644 --- a/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs +++ b/testsuite/tests/typecheck/should_run/EtaExpandLevPoly.hs @@ -6,12 +6,12 @@ module Main where import GHC.Exts data G a where - MkG :: G (TupleRep [LiftedRep, IntRep]) + MkG :: G (TupleRep [BoxedRep Lifted, IntRep]) -- tests that we don't eta-expand functions that are levity-polymorphic -- see CoreArity.mkEtaWW foo :: forall a (b :: TYPE a). G a -> b -> b -foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [LiftedRep, IntRep])). c -> c +foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [BoxedRep Lifted, IntRep])). c -> c data H a where MkH :: H IntRep diff --git a/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs b/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs new file mode 100644 index 0000000000..8302a43693 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/LevPolyResultInst.hs @@ -0,0 +1,27 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language UnboxedTuples #-} + +import GHC.Exts + +main :: IO () +main = do + print (example (\x -> I# x > 7)) + case indexArray# (example replicateFalse) 0# of + (# r #) -> print r + +-- Combines base:runST, primitive:newArray, and primitive:unsafeFreezeArray +replicateFalse :: Int# -> Array# Bool +replicateFalse n = + let !(# _, r #) = runRW# + (\s -> case newArray# n False s of + (# s', arr #) -> unsafeFreezeArray# arr s' + ) + in r + +example :: forall (v :: Levity) (a :: TYPE ('BoxedRep v)). (Int# -> a) -> a +{-# noinline example #-} +example f = f 8# diff --git a/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout b/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout new file mode 100644 index 0000000000..1cc8b5e10d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/LevPolyResultInst.stdout @@ -0,0 +1,2 @@ +True +False diff --git a/testsuite/tests/typecheck/should_run/T12809.hs b/testsuite/tests/typecheck/should_run/T12809.hs index 66031a5af7..3e20403add 100644 --- a/testsuite/tests/typecheck/should_run/T12809.hs +++ b/testsuite/tests/typecheck/should_run/T12809.hs @@ -32,7 +32,7 @@ g (# b, x #) = show b ++ " " ++ show (I# x) h :: (# Double, Int# #) -> String h (# d, x #) = show d ++ " " ++ show (I# x) -cond :: forall (a :: TYPE (TupleRep [LiftedRep, IntRep])). Bool -> a -> a -> a +cond :: forall (a :: TYPE (TupleRep [BoxedRep Lifted, IntRep])). Bool -> a -> a -> a cond True x _ = x cond False _ x = x diff --git a/testsuite/tests/typecheck/should_run/T14236.stdout b/testsuite/tests/typecheck/should_run/T14236.stdout index ffa0e65dc9..73c98017f2 100644 --- a/testsuite/tests/typecheck/should_run/T14236.stdout +++ b/testsuite/tests/typecheck/should_run/T14236.stdout @@ -1,3 +1,3 @@ -(FUN 'Many 'LiftedRep 'LiftedRep Int,Char) -(FUN 'Many 'IntRep 'LiftedRep Int#,Char) +(FUN 'Many ('BoxedRep 'Lifted) ('BoxedRep 'Lifted) Int,Char) +(FUN 'Many 'IntRep ('BoxedRep 'Lifted) Int#,Char) Int# -> [Char] diff --git a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout index 1303db844c..6ef72dfb83 100644 --- a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout +++ b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout @@ -5,7 +5,7 @@ good: Maybe good: TYPE good: RuntimeRep good: 'IntRep -good: FUN 'Many 'LiftedRep 'LiftedRep +good: FUN 'Many ('BoxedRep 'Lifted) ('BoxedRep 'Lifted) good: Proxy * Int good: Proxy (TYPE 'IntRep) Int# good: * diff --git a/testsuite/tests/typecheck/should_run/TypeOf.hs b/testsuite/tests/typecheck/should_run/TypeOf.hs index cec6833b64..37113bfe80 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.hs +++ b/testsuite/tests/typecheck/should_run/TypeOf.hs @@ -28,9 +28,12 @@ main = do print $ typeOf (Proxy :: Proxy [1,2,3]) print $ typeOf (Proxy :: Proxy 'EQ) print $ typeOf (Proxy :: Proxy TYPE) - print $ typeOf (Proxy :: Proxy (TYPE 'LiftedRep)) + print $ typeOf (Proxy :: Proxy (TYPE ('BoxedRep 'Lifted))) print $ typeOf (Proxy :: Proxy *) print $ typeOf (Proxy :: Proxy ★) - print $ typeOf (Proxy :: Proxy 'LiftedRep) + print $ typeOf (Proxy :: Proxy ('BoxedRep 'Lifted)) + print $ typeOf (Proxy :: Proxy 'Lifted) + print $ typeOf (Proxy :: Proxy 'Unlifted) + print $ typeOf (Proxy :: Proxy LiftedRep) print $ typeOf (Proxy :: Proxy '(1, "hello")) print $ typeOf (Proxy :: Proxy (~~)) diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout index 40d2cb5f8f..3344f17193 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.stdout +++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout @@ -19,6 +19,9 @@ Proxy (RuntimeRep -> *) TYPE Proxy * * Proxy * * Proxy * * -Proxy RuntimeRep 'LiftedRep +Proxy RuntimeRep ('BoxedRep 'Lifted) +Proxy Levity 'Lifted +Proxy Levity 'Unlifted +Proxy RuntimeRep ('BoxedRep 'Lifted) Proxy (Natural,Symbol) ('(,) Natural Symbol 1 "hello") Proxy (* -> * -> Constraint) ((~~) * *) diff --git a/testsuite/tests/typecheck/should_run/TypeRep.hs b/testsuite/tests/typecheck/should_run/TypeRep.hs index beae93f6b3..886479fd33 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.hs +++ b/testsuite/tests/typecheck/should_run/TypeRep.hs @@ -53,10 +53,10 @@ main = do print $ rep @(Proxy [1,2,3]) print $ rep @(Proxy 'EQ) print $ rep @(Proxy TYPE) - print $ rep @(Proxy (TYPE 'LiftedRep)) + print $ rep @(Proxy (TYPE ('BoxedRep 'Lifted))) print $ rep @(Proxy *) print $ rep @(Proxy ★) - print $ rep @(Proxy 'LiftedRep) + print $ rep @(Proxy ('BoxedRep 'Lifted)) -- Something lifted and primitive print $ rep @RealWorld -- #12132 diff --git a/testsuite/tests/typecheck/should_run/TypeRep.stdout b/testsuite/tests/typecheck/should_run/TypeRep.stdout index a0c03e09d8..cf43264714 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.stdout +++ b/testsuite/tests/typecheck/should_run/TypeRep.stdout @@ -13,7 +13,7 @@ Int -> Int (%,%) (Eq Int) (Eq [Char]) Int# (##) -(#,#) 'IntRep 'LiftedRep Int# Int +(#,#) 'IntRep ('BoxedRep 'Lifted) Int# Int Proxy Constraint (Eq Int) Proxy * (Int,Int) Proxy Symbol "hello world" @@ -24,5 +24,5 @@ Proxy (RuntimeRep -> *) TYPE Proxy * * Proxy * * Proxy * * -Proxy RuntimeRep 'LiftedRep +Proxy RuntimeRep ('BoxedRep 'Lifted) RealWorld diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index ef8ae9136d..ef7bedb354 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -145,5 +145,6 @@ test('UnliftedNewtypesFamilyRun', normal, compile_and_run, ['']) test('UnliftedNewtypesDependentFamilyRun', normal, compile_and_run, ['']) test('UnliftedNewtypesIdentityRun', normal, compile_and_run, ['']) test('UnliftedNewtypesCoerceRun', normal, compile_and_run, ['']) +test('LevPolyResultInst', normal, compile_and_run, ['']) test('T17104', normal, compile_and_run, ['']) test('T18627', normal, compile_and_run, ['-O']) # Optimisation shows up the bug |