[Git][ghc/ghc][wip/with2-primop] 3 commits: Add tests
Ben Gamari
gitlab at gitlab.haskell.org
Thu Apr 16 00:59:33 UTC 2020
Ben Gamari pushed to branch wip/with2-primop at Glasgow Haskell Compiler / GHC
Commits:
17323cb1 by Ben Gamari at 2020-04-15T20:27:17-04:00
Add tests
- - - - -
44651702 by Ben Gamari at 2020-04-15T20:27:26-04:00
Fix return type
- - - - -
7b01122e by Ben Gamari at 2020-04-15T20:59:24-04:00
Fix it
- - - - -
6 changed files:
- compiler/GHC/Core/Op/Simplify.hs
- compiler/GHC/CoreToStg/Prep.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/keepAliveSimplificationA.hs
- + testsuite/tests/simplCore/should_run/T18061.hs
- testsuite/tests/simplCore/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/Op/Simplify.hs
=====================================
@@ -1885,18 +1885,22 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
, [ ValArg s0
, ValArg (Lam f_arg f_body)
, ValArg x
- , TyArg {}
- , TyArg {}
+ , TyArg {} -- res_ty
+ , TyArg {} -- res_rep
, TyArg {as_arg_ty=arg_ty}
, TyArg {as_arg_ty=arg_rep}
] <- rev_args
= do { (env', f_arg) <- simplLamBndr (zapSubstEnv env) f_arg
; f_body' <- simplExprC env' f_body cont
; let f' = Lam f_arg f_body'
- ty' = contResultType cont
- call' = mkApps (Var fun)
- [ mkTyArg (getRuntimeRep ty'), mkTyArg ty'
- , mkTyArg arg_rep, mkTyArg arg_ty
+ -- Extract type of second component of (# State# RealWorld, a #)
+ ty' = case splitTyConApp_maybe (contResultType cont) of
+ Just (tc, [_, _, _, ty]) -> ty
+ Nothing -> panic "rebuildCall: Malformed (#,#) type"
+
+ ; let call' = mkApps (Var fun)
+ [ mkTyArg arg_rep, mkTyArg arg_ty
+ , mkTyArg (getRuntimeRep ty'), mkTyArg ty'
, x
, f'
, s0
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -857,13 +857,15 @@ cpeApp top_env expr
_ -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
-- See Note [CorePrep handling of keepAlive#]
- cpe_app env (Var f) [CpeApp (Type _arg_rep), CpeApp (Type arg_ty),
+ cpe_app env (Var f) [CpeApp (Type arg_rep), CpeApp (Type arg_ty),
CpeApp (Type result_rep), CpeApp (Type result_ty),
CpeApp x, CpeApp k, CpeApp s0] 3
| f `hasKey` keepAliveIdKey
= do { let voidRepTy = primRepToRuntimeRep VoidRep
- ; b0 <- newVar $ mkTyConApp (tupleTyCon Unboxed 2)
- [voidRepTy, result_rep, realWorldStatePrimTy, result_ty]
+ -- out_ty ~ (# State# RealWorld, a #)
+ out_ty = mkTyConApp (tupleTyCon Unboxed 2)
+ [voidRepTy, result_rep, realWorldStatePrimTy, result_ty]
+ ; b0 <- newVar out_ty
; y <- newVar result_ty
; s1 <- newVar realWorldStatePrimTy
; s2 <- newVar realWorldStatePrimTy
@@ -875,9 +877,11 @@ cpeApp top_env expr
stateResultAlt stateVar resultVar rhs =
(DataAlt (tupleDataCon Unboxed 2), [stateVar, resultVar], rhs)
- expr = Case (App k s0) b0 (varType b0) [stateResultAlt s1 y rhs1]
- rhs1 = Case (mkApps (Var touchId) [Type arg_ty, x, Var s1]) s1 (varType s1) [(DEFAULT, [], rhs2)]
- rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Var s2, Var y]
+ expr = Case (App k s0) b0 out_ty [stateResultAlt s1 y rhs1]
+ rhs1 = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, x, Var s1]
+ in Case scrut s2 out_ty [(DEFAULT, [], rhs2)]
+ rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2)
+ [mkTyArg voidRepTy, mkTyArg result_rep, mkTyArg realWorldStatePrimTy, mkTyArg result_ty, Var s2, Var y]
; cpeBody env expr
}
cpe_app _env (Var f) args _
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -327,3 +327,4 @@ test('T17966',
# NB: T17810: -fspecialise-aggressively
test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
test('T18013', normal, multimod_compile, ['T18013', '-v0 -O'])
+test('keepAliveSimplificationA', grep_errmsg(r'43#'), compile, ['-O -ddump-simpl'])
=====================================
testsuite/tests/simplCore/should_compile/keepAliveSimplificationA.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE MagicHash #-}
+
+module Hi (g) where
+
+import GHC.Prim
+import GHC.IO
+import GHC.Int
+
+keepAlive :: a -> IO r -> IO r
+keepAlive x f = IO $ \s -> keepAlive# x (unIO f) s
+{-# INLINE keepAlive #-}
+
+f :: a -> IO Int
+f x = keepAlive x $ return 41
+
+-- The 'succ' should be folded into the continuation given to
+-- keepAlive; constant folding will then turn the 41# into a 42#, which is what
+-- we check for in this test.
+g :: a -> IO Int
+g x = succ <$> f x
=====================================
testsuite/tests/simplCore/should_run/T18061.hs
=====================================
@@ -0,0 +1,19 @@
+module T18061 where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Word
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Numeric
+
+main :: IO ()
+main = do
+ replicateM_ 49 $ threadDelay 1
+ fptr <- mallocForeignPtrBytes 4
+ withForeignPtr fptr $ \p ->
+ forever $ do
+ poke p (0xDEADBEEF :: Word32)
+ threadDelay 10
+ x <- peek p
+ unless (x == 0xDEADBEEF) $ putStrLn (showHex x "")
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -93,3 +93,4 @@ test('T15840a', normal, compile_and_run, [''])
test('T16066', exit_code(1), compile_and_run, ['-O1'])
test('T17206', exit_code(1), compile_and_run, [''])
test('T17151', [], multimod_compile_and_run, ['T17151', ''])
+test('T18061', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ccce995c91f8c037f906d66df5865b01a687f7b...7b01122e0159f2abeccef0376745e46355501555
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ccce995c91f8c037f906d66df5865b01a687f7b...7b01122e0159f2abeccef0376745e46355501555
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200415/6f37bc46/attachment-0001.html>
More information about the ghc-commits
mailing list