diff options
author | RyanGlScott <ryan.gl.scott@gmail.com> | 2015-12-22 11:25:59 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-22 13:22:29 +0100 |
commit | f975b0b10b2971d00b6e1986e0a2af2bf759a4f4 (patch) | |
tree | 8b890f6e8058bb0a625a409de70f107101048d8d /testsuite/tests/th | |
parent | b407bd775d9241023b4694b3142a756df0082ea2 (diff) | |
download | haskell-f975b0b10b2971d00b6e1986e0a2af2bf759a4f4.tar.gz |
Rework Template Haskell's handling of strictness
Currently, Template Haskell's treatment of strictness is not enough to
cover all possible combinations of unpackedness and strictness. In
addition, it isn't equipped to deal with new features (such as
`-XStrictData`) which can change a datatype's fields' strictness during
compilation.
To address this, I replaced TH's `Strict` datatype with
`SourceUnpackedness` and `SourceStrictness` (which give the programmer a
more complete toolkit to configure a datatype field's strictness than
just `IsStrict`, `IsLazy`, and `Unpack`). I also added the ability to
reify a constructor fields' strictness post-compilation through the
`reifyConStrictness` function.
Fixes #10697.
Test Plan: ./validate
Reviewers: simonpj, goldfire, bgamari, austin
Reviewed By: goldfire, bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D1603
GHC Trac Issues: #10697
Diffstat (limited to 'testsuite/tests/th')
22 files changed, 216 insertions, 30 deletions
diff --git a/testsuite/tests/th/T10697_decided_1.hs b/testsuite/tests/th/T10697_decided_1.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_1.stdout b/testsuite/tests/th/T10697_decided_1.stdout new file mode 100644 index 0000000000..b0dd4a284a --- /dev/null +++ b/testsuite/tests/th/T10697_decided_1.stdout @@ -0,0 +1 @@ +[DecidedStrict,DecidedStrict,DecidedLazy] diff --git a/testsuite/tests/th/T10697_decided_2.hs b/testsuite/tests/th/T10697_decided_2.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_2.stdout b/testsuite/tests/th/T10697_decided_2.stdout new file mode 100644 index 0000000000..c4cfc4ab79 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_2.stdout @@ -0,0 +1 @@ +[DecidedStrict,DecidedStrict,DecidedStrict] diff --git a/testsuite/tests/th/T10697_decided_3.hs b/testsuite/tests/th/T10697_decided_3.hs new file mode 100644 index 0000000000..241cec3d38 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +data T = T {-# UNPACK #-} !Int !Int Int + +$(return []) + +main :: IO () +main = putStrLn $(reifyConStrictness 'T >>= stringE . show) diff --git a/testsuite/tests/th/T10697_decided_3.stdout b/testsuite/tests/th/T10697_decided_3.stdout new file mode 100644 index 0000000000..ae59571a61 --- /dev/null +++ b/testsuite/tests/th/T10697_decided_3.stdout @@ -0,0 +1 @@ +[DecidedUnpack,DecidedUnpack,DecidedUnpack] diff --git a/testsuite/tests/th/T10697_source.hs b/testsuite/tests/th/T10697_source.hs new file mode 100644 index 0000000000..4dfa410168 --- /dev/null +++ b/testsuite/tests/th/T10697_source.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE StrictData, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH +import T10697_sourceUtil + +$([d|data A1 = A1 Int {- No unpackedness, no strictness -}|]) +$([d|data A2 = A2 !Int {- No unpackedness, strict -}|]) +$([d|data A3 = A3 ~Int {- No unpackedness, lazy -}|]) +$([d|data A4 = A4 {-# NOUNPACK #-} Int {- NOUNPACK, no strictness -}|]) +$([d|data A5 = A5 {-# NOUNPACK #-} !Int {- NOUNPACK, strict -}|]) +$([d|data A6 = A6 {-# NOUNPACK #-} ~Int {- NOUNPACK, lazy -}|]) +$([d|data A7 = A7 {-# UNPACK #-} Int {- UNPACK, no strictness -}|]) +$([d|data A8 = A8 {-# UNPACK #-} !Int {- UNPACK, strict -}|]) +$([d|data A9 = A9 {-# UNPACK #-} ~Int {- UNPACK, lazy -}|]) + +$(do b1 <- newName "B1" + b2 <- newName "B2" + b3 <- newName "B3" + b4 <- newName "B4" + b5 <- newName "B5" + b6 <- newName "B6" + b7 <- newName "B7" + b8 <- newName "B8" + b9 <- newName "B9" + c1 <- newName "C1" + c2 <- newName "C2" + c3 <- newName "C3" + c4 <- newName "C4" + c5 <- newName "C5" + c6 <- newName "C6" + c7 <- newName "C7" + c8 <- newName "C8" + c9 <- newName "C9" + + d1 <- makeSimpleDatatype b1 c1 noSourceUnpackedness noSourceStrictness + d2 <- makeSimpleDatatype b2 c2 noSourceUnpackedness sourceStrict + d3 <- makeSimpleDatatype b3 c3 noSourceUnpackedness sourceLazy + d4 <- makeSimpleDatatype b4 c4 sourceNoUnpack noSourceStrictness + d5 <- makeSimpleDatatype b5 c5 sourceNoUnpack sourceStrict + d6 <- makeSimpleDatatype b6 c6 sourceNoUnpack sourceLazy + d7 <- makeSimpleDatatype b7 c7 sourceUnpack noSourceStrictness + d8 <- makeSimpleDatatype b8 c8 sourceUnpack sourceStrict + d9 <- makeSimpleDatatype b9 c9 sourceUnpack sourceLazy + return [d1, d2, d3, d4, d5, d6, d7, d8, d9]) + +main :: IO () +main = mapM_ print [ $(checkBang ''E1 noSourceUnpackedness noSourceStrictness) + , $(checkBang ''E2 noSourceUnpackedness sourceStrict) + , $(checkBang ''E3 noSourceUnpackedness sourceLazy) + , $(checkBang ''E4 sourceNoUnpack noSourceStrictness) + , $(checkBang ''E5 sourceNoUnpack sourceStrict) + , $(checkBang ''E6 sourceNoUnpack sourceLazy) + , $(checkBang ''E7 sourceUnpack noSourceStrictness) + , $(checkBang ''E8 sourceUnpack sourceStrict) + , $(checkBang ''E9 sourceUnpack sourceLazy) + ] diff --git a/testsuite/tests/th/T10697_source.stdout b/testsuite/tests/th/T10697_source.stdout new file mode 100644 index 0000000000..c4dc445159 --- /dev/null +++ b/testsuite/tests/th/T10697_source.stdout @@ -0,0 +1,9 @@ +True +True +True +True +True +True +True +True +True diff --git a/testsuite/tests/th/T10697_sourceUtil.hs b/testsuite/tests/th/T10697_sourceUtil.hs new file mode 100644 index 0000000000..048a422b99 --- /dev/null +++ b/testsuite/tests/th/T10697_sourceUtil.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE StrictData, TemplateHaskell #-} +module T10697_sourceUtil where + +import Language.Haskell.TH + +makeSimpleDatatype :: Name + -> Name + -> SourceUnpackednessQ + -> SourceStrictnessQ + -> Q Dec +makeSimpleDatatype tyName conName srcUpk srcStr = + dataD (cxt []) tyName [] Nothing [normalC conName + [bangType (bang srcUpk srcStr) (conT ''Int)]] (cxt []) + +checkBang :: Name + -> SourceUnpackednessQ + -> SourceStrictnessQ + -> ExpQ +checkBang n srcUpk1 srcStr1 = do + TyConI (DataD _ _ _ _ [NormalC _ [(Bang srcUpk2 srcStr2, _)]] _) <- reify n + srcUpk1' <- srcUpk1 + srcStr1' <- srcStr1 + if srcUpk1' == srcUpk2 && srcStr1' == srcStr2 + then [| True |] + else [| False |] + +data E1 = E1 Int -- No unpackedness, no strictness +data E2 = E2 !Int -- No unpackedness, strict +data E3 = E3 ~Int -- No unpackedness, lazy +data E4 = E4 {-# NOUNPACK #-} Int -- NOUNPACK, no strictness +data E5 = E5 {-# NOUNPACK #-} !Int -- NOUNPACK, strict +data E6 = E6 {-# NOUNPACK #-} ~Int -- NOUNPACK, lazy +data E7 = E7 {-# UNPACK #-} Int -- UNPACK, no strictness +data E8 = E8 {-# UNPACK #-} !Int -- UNPACK, strict +data E9 = E9 {-# UNPACK #-} ~Int -- UNPACK, lazy diff --git a/testsuite/tests/th/T10819_Lib.hs b/testsuite/tests/th/T10819_Lib.hs index 94f352efe7..2be00b4a51 100644 --- a/testsuite/tests/th/T10819_Lib.hs +++ b/testsuite/tests/th/T10819_Lib.hs @@ -2,6 +2,6 @@ module T10819_Lib where import Language.Haskell.TH.Syntax -doSomeTH s tp drv = return [NewtypeD [] n [] Nothing - (NormalC n [(NotStrict, ConT tp)]) drv] +doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] where n = mkName s diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs index f01c5b9769..75b852ff07 100644 --- a/testsuite/tests/th/T10828.hs +++ b/testsuite/tests/th/T10828.hs @@ -33,16 +33,28 @@ $( return [ PlainTV (mkName "a") ] (Just StarT) [ GadtC [(mkName "MkT")] - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] ( mkName "T" ) [ VarT (mkName "a") ] , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ RecGadtC [(mkName "MkC")] - [ (mkName "foo", NotStrict, VarT (mkName "a")) - , (mkName "bar", NotStrict, VarT (mkName "b"))] + [ ( mkName "foo" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( mkName "bar" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "b") + ) + ] ( mkName "T" ) [ ConT (mkName "Int") ] ] [] ]) diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs index 8bf13cfb04..c3108c3e38 100644 --- a/testsuite/tests/th/T10828a.hs +++ b/testsuite/tests/th/T10828a.hs @@ -11,7 +11,12 @@ $( return [ PlainTV (mkName "a") ] (Just StarT) [ NormalC (mkName "MkT") - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] ] [] ]) diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs index 55d8889009..ac4f6a28e5 100644 --- a/testsuite/tests/th/T10828b.hs +++ b/testsuite/tests/th/T10828b.hs @@ -10,16 +10,30 @@ $( return [ DataD [] (mkName "T") [ PlainTV (mkName "a") ] (Just StarT) - [ NormalC (mkName "MkT") - [ (NotStrict, VarT (mkName "a")) - , (NotStrict, VarT (mkName "a"))] + [ NormalC + (mkName "MkT") + [ ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + ] , ForallC [PlainTV (mkName "a")] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ - RecGadtC [(mkName "MkC")] - [ (mkName "foo", NotStrict, VarT (mkName "a")) - , (mkName "bar", NotStrict, VarT (mkName "b"))] - ( mkName "T" ) - [ ConT (mkName "Int") ] + RecGadtC + [ (mkName "MkC")] + [ ( mkName "foo" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "a") + ) + , ( mkName "bar" + , Bang NoSourceUnpackedness NoSourceStrictness + , VarT (mkName "b") + ) + ] + ( mkName "T" ) + [ ConT (mkName "Int") ] ] [] ]) diff --git a/testsuite/tests/th/T5290.hs b/testsuite/tests/th/T5290.hs index 50ad2d500c..2215ef1075 100644 --- a/testsuite/tests/th/T5290.hs +++ b/testsuite/tests/th/T5290.hs @@ -5,4 +5,5 @@ module T5290 where import Language.Haskell.TH $( let n = mkName "T" - in return [DataD [] n [] Nothing [NormalC n [(Unpacked,ConT ''Int)]] []] ) + in return [DataD [] n [] Nothing + [NormalC n [(Bang SourceUnpack SourceStrict,ConT ''Int)]] []] ) diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr index d6996d0799..19c962a9a0 100644 --- a/testsuite/tests/th/T5290.stderr +++ b/testsuite/tests/th/T5290.stderr @@ -1,7 +1,13 @@ -T5290.hs:(7,4)-(8,75): Splicing declarations +T5290.hs:(7,4)-(9,77): Splicing declarations let n = mkName "T" in return - [DataD [] n [] Nothing [NormalC n [(Unpacked, ConT ''Int)]] []] + [DataD + [] + n + [] + Nothing + [NormalC n [(Bang SourceUnpack SourceStrict, ConT ''Int)]] + []] ======> data T = T {-# UNPACK #-} !Int diff --git a/testsuite/tests/th/T5665a.hs b/testsuite/tests/th/T5665a.hs index b34131e974..2b558271b3 100644 --- a/testsuite/tests/th/T5665a.hs +++ b/testsuite/tests/th/T5665a.hs @@ -2,6 +2,6 @@ module T5665a where import Language.Haskell.TH -doSomeTH s tp = return [NewtypeD [] n [] Nothing - (NormalC n [(NotStrict, ConT tp)]) []] +doSomeTH s tp = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) []] where n = mkName s diff --git a/testsuite/tests/th/T5984_Lib.hs b/testsuite/tests/th/T5984_Lib.hs index a929086dd2..d8913cd8f3 100644 --- a/testsuite/tests/th/T5984_Lib.hs +++ b/testsuite/tests/th/T5984_Lib.hs @@ -5,10 +5,11 @@ module T5984_Lib where import Language.Haskell.TH nt :: Q [Dec] -nt = return [NewtypeD [] foo [] Nothing - (NormalC foo [(NotStrict, ConT ''Int)]) []] +nt = return [NewtypeD [] foo [] Nothing (NormalC foo + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]) []] where foo = mkName "Foo" dt :: Q [Dec] -dt = return [DataD [] bar [] Nothing [NormalC bar [(NotStrict, ConT ''Int)]] []] +dt = return [DataD [] bar [] Nothing [NormalC bar + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]] []] where bar = mkName "Bar" diff --git a/testsuite/tests/th/T7532.hs b/testsuite/tests/th/T7532.hs index 3a641ea97a..a7604710f5 100644 --- a/testsuite/tests/th/T7532.hs +++ b/testsuite/tests/th/T7532.hs @@ -8,4 +8,4 @@ import T7532a instance C Bool where data D Bool = MkD -$(bang) +$(bang') diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr index 3e57bb8955..baaf04f3f5 100644 --- a/testsuite/tests/th/T7532.stderr +++ b/testsuite/tests/th/T7532.stderr @@ -3,8 +3,8 @@ instance C Bool where data D Bool = T7532.MkD -T7532.hs:11:3-6: Splicing declarations - bang +T7532.hs:11:3-7: Splicing declarations + bang' ======> instance C Int where data D Int = T diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs index 42976b393c..901e27a1bf 100644 --- a/testsuite/tests/th/T7532a.hs +++ b/testsuite/tests/th/T7532a.hs @@ -8,8 +8,8 @@ import Language.Haskell.TH class C a where data D a -bang :: DecsQ -bang = return [ +bang' :: DecsQ +bang' = return [ InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [ DataInstD [] ''D [ConT ''Int] Nothing [ NormalC (mkName "T") []] []]] diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs index 5e1ee0bfc0..25091c4ecf 100644 --- a/testsuite/tests/th/TH_genExLib.hs +++ b/testsuite/tests/th/TH_genExLib.hs @@ -16,5 +16,6 @@ genAnyClass name decls where anyName = mkName ("Any" ++ nameBase name ++ "1111") constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $ - NormalC anyName [(NotStrict, VarT var_a)] + NormalC anyName + [(Bang NoSourceUnpackedness NoSourceStrictness, VarT var_a)] var_a = mkName "a" diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 5a55b6f0da..9d00d8e856 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -358,6 +358,15 @@ test('T10306', normal, compile, ['-v0']) test('T10596', normal, compile, ['-v0']) test('T10620', normal, compile_and_run, ['-v0']) test('T10638', normal, compile_fail, ['-v0']) +test('T10697_decided_1', normal, compile_and_run, ['-v0']) +test('T10697_decided_2', normal, compile_and_run, ['-XStrictData -v0']) +test('T10697_decided_3', normal, + compile_and_run, + ['-XStrictData -funbox-strict-fields -O2 -v0']) +test('T10697_source', + extra_clean(['T10697_sourceUtil.hi', 'T10697_sourceUtil.o']), + multimod_compile_and_run, + ['T10697_source', '-w ' + config.ghc_th_way_flags]) test('T10704', extra_clean(['T10704a.o','T10704a.hi']), multimod_compile_and_run, |