[Git][ghc/ghc][wip/ioref-swap-xchg] 10 commits: DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997)
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu Mar 16 15:38:14 UTC 2023
Ben Gamari pushed to branch wip/ioref-swap-xchg at Glasgow Haskell Compiler / GHC
Commits:
ec2d93eb by Sebastian Graf at 2023-03-10T10:18:54-05:00
DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997)
We should not panic in `add_demands` (now `set_lam_dmds`), because that code
path is legimitely taken for OPAQUE PAP bindings, as in T22997.
Fixes #22997.
- - - - -
5b4628ae by Sylvain Henry at 2023-03-10T10:19:34-05:00
JS: remove dead code for old integer-gmp
- - - - -
bab23279 by Josh Meredith at 2023-03-10T23:24:49-05:00
JS: Fix implementation of MK_JSVAL
- - - - -
ec263a59 by Sebastian Graf at 2023-03-10T23:25:25-05:00
Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check
There is no need to run arity analysis and what not if we are not in a
Simplifier phase that eta-expands or if we don't want to eta-expand the
expression in the first place.
Purely a refactoring with the goal of improving compiler perf.
- - - - -
047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00
JS: fix implementation of forceBool to use JS backend syntax
- - - - -
559a4804 by Sebastian Graf at 2023-03-13T07:31:23-04:00
Simplifier: `countValArgs` should not count Type args (#23102)
I observed miscompilations while working on !10088 caused by this.
Fixes #23102.
Metric Decrease:
T10421
- - - - -
536d1f90 by Matthew Pickering at 2023-03-13T14:04:49+00:00
Bump Win32 to 2.13.4.0
Updates Win32 submodule
- - - - -
ee17001e by Ben Gamari at 2023-03-13T21:18:24-04:00
ghc-bignum: Drop redundant include-dirs field
- - - - -
36389b5a by Ben Gamari at 2023-03-16T11:38:03-04:00
compiler: Implement atomicSwapIORef with xchg
- - - - -
c69091a1 by Ben Gamari at 2023-03-16T11:38:04-04:00
testsuite: Add test for atomicSwapIORef#
- - - - -
20 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/Win32
- libraries/base/GHC/IORef.hs
- + libraries/base/tests/AtomicSwapIORef.hs
- libraries/base/tests/all.T
- libraries/ghc-bignum/ghc-bignum.cabal
- rts/PrimOps.cmm
- rts/include/Cmm.h
- rts/js/rts.js
- + testsuite/tests/javascript/T23101.hs
- + testsuite/tests/javascript/T23101.stdout
- + testsuite/tests/javascript/all.T
- + testsuite/tests/stranal/should_compile/T22997.hs
- testsuite/tests/stranal/should_compile/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2464,6 +2464,13 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp
has_side_effects = True
code_size = { primOpCodeSizeForeignCall } -- for the write barrier
+primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp
+ MutVar# s v -> v -> State# s -> (# State# s, a #)
+ {Atomically exchange the value of a 'MutVar#'.}
+ with
+ out_of_line = True
+ has_side_effects = True
+
-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Looking at the type of atomicModifyMutVar2#, one might wonder why
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1916,10 +1916,11 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
-- Check for an OPAQUE function: see Note [OPAQUE pragma]
-- In that case, trim off all boxity info from argument demands
+ -- and demand info on lambda binders
-- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
| isOpaquePragma (idInlinePragma fn)
, let trimmed_rhs_dmds = map trimBoxity rhs_dmds
- = (trimmed_rhs_dmds, add_demands trimmed_rhs_dmds rhs)
+ = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs)
-- Check that we have enough visible binders to match the
-- threshold arity; if not, we won't do worker/wrapper
@@ -1939,8 +1940,8 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
-- vcat [text "function:" <+> ppr fn
-- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
-- , text "dmds after: " <+> ppr arg_dmds' ]) $
- (arg_dmds', add_demands arg_dmds' rhs)
- -- add_demands: we must attach the final boxities to the lambda-binders
+ (arg_dmds', set_lam_dmds arg_dmds' rhs)
+ -- set_lam_dmds: we must attach the final boxities to the lambda-binders
-- of the function, both because that's kosher, and because CPR analysis
-- uses the info on the binders directly.
where
@@ -2032,17 +2033,18 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
| positiveTopBudget bg_inner' = (bg_inner', dmd')
| otherwise = (bg_inner, trimBoxity dmd)
- add_demands :: [Demand] -> CoreExpr -> CoreExpr
+ set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr
-- Attach the demands to the outer lambdas of this expression
- add_demands [] e = e
- add_demands (dmd:dmds) (Lam v e)
- | isTyVar v = Lam v (add_demands (dmd:dmds) e)
- | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)
- add_demands dmds (Cast e co) = Cast (add_demands dmds e) co
+ set_lam_dmds (dmd:dmds) (Lam v e)
+ | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e)
+ | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e)
+ set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co
-- This case happens for an OPAQUE function, which may look like
-- f = (\x y. blah) |> co
-- We give it strictness but no boxity (#22502)
- add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
+ set_lam_dmds _ e = e
+ -- In the OPAQUE case, the list of demands at this point might be
+ -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997).
finaliseLetBoxity
:: AnalEnv
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -553,7 +553,7 @@ countArgs _ = 0
countValArgs :: SimplCont -> Int
-- Count value arguments only
-countValArgs (ApplyToTy { sc_cont = cont }) = 1 + countValArgs cont
+countValArgs (ApplyToTy { sc_cont = cont }) = countValArgs cont
countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont
countValArgs (CastIt _ cont) = countValArgs cont
countValArgs _ = 0
@@ -1859,11 +1859,12 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-> SimplM (ArityType, OutExpr)
-- See Note [Eta-expanding at let bindings]
tryEtaExpandRhs env bind_cxt bndr rhs
- | do_eta_expand -- If the current manifest arity isn't enough
- -- (never true for join points)
- , seEtaExpand env -- and eta-expansion is on
- , wantEtaExpansion rhs
- = -- Do eta-expansion.
+ | seEtaExpand env -- If Eta-expansion is on
+ , wantEtaExpansion rhs -- and we'd like to eta-expand e
+ , do_eta_expand -- and e's manifest arity is lower than
+ -- what it could be
+ -- (never true for join points)
+ = -- Do eta-expansion.
assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $
-- assert: this never happens for join points; see GHC.Core.Opt.Arity
-- Note [Do not eta-expand join points]
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -639,7 +639,7 @@ jsResultWrapper result_ty
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do
-- result_id <- newSysLocalDs boolTy
ccall_uniq <- newUnique
- let forceBool e = mkJsCall ccall_uniq (fsLit "$r = !(!$1)") [e] boolTy
+ let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy
return
(Just intPrimTy, \e -> forceBool e)
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1559,6 +1559,7 @@ emitPrimOp cfg primop =
ResizeMutableByteArrayOp_Char -> alwaysExternal
ShrinkSmallMutableArrayOp_Char -> alwaysExternal
NewMutVarOp -> alwaysExternal
+ AtomicSwapMutVarOp -> alwaysExternal
AtomicModifyMutVar2Op -> alwaysExternal
AtomicModifyMutVar_Op -> alwaysExternal
CasMutVarOp -> alwaysExternal
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -115,8 +115,8 @@ genCommonCppDefs profiling = mconcat
-- GHCJS.Prim.JSVal
, if profiling
- then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"
- else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"
+ then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"
+ else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n"
, "#define JSVAL_VAL(x) ((x).d1)\n"
-- GHCJS.Prim.JSException
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -859,6 +859,8 @@ genPrim prof bound ty op = case op of
AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]
AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]
+ AtomicSwapMutVarOp -> \[status,r] [mv,v] -> PrimInline $ mconcat
+ [ r |= mv .^ "val", mv .^ "val" |= v ]
CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o)
(mconcat [status |= zero_, r |= n, mv .^ "val" |= n])
(mconcat [status |= one_ , r |= mv .^ "val"])
=====================================
libraries/Win32
=====================================
@@ -1 +1 @@
-Subproject commit 931497f7052f63cb5cfd4494a94e572c5c570642
+Subproject commit efab7f1146da9741dc54fb35476d4aaabeff8d6d
=====================================
libraries/base/GHC/IORef.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.IORef (
import GHC.Base
import GHC.STRef
import GHC.IO
+import GHC.Prim (atomicSwapMutVar#)
-- ---------------------------------------------------------------------------
-- IORefs
@@ -127,10 +128,9 @@ atomicModifyIORef'_ ref f = do
-- | Atomically replace the contents of an 'IORef', returning
-- the old contents.
atomicSwapIORef :: IORef a -> a -> IO a
--- Bad implementation! This will be a primop shortly.
atomicSwapIORef (IORef (STRef ref)) new = IO $ \s ->
- case atomicModifyMutVar2# ref (\_old -> Box new) s of
- (# s', old, Box _new #) -> (# s', old #)
+ case atomicSwapMutVar# ref new s of
+ (# s', old #) -> (# s', old #)
data Box a = Box a
=====================================
libraries/base/tests/AtomicSwapIORef.hs
=====================================
@@ -0,0 +1,7 @@
+import Data.IORef
+
+main :: IO ()
+main = do
+ r <- newIORef 42 :: IO Int
+ atomicSwapIORef r 43
+ readIORef r >>= print
=====================================
libraries/base/tests/all.T
=====================================
@@ -296,3 +296,4 @@ test('T22816', normal, compile_and_run, [''])
test('trace', normal, compile_and_run, [''])
test('listThreads', js_broken(22261), compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
+test('AtomicSwapIORef', normal, compile_and_run, [''])
=====================================
libraries/ghc-bignum/ghc-bignum.cabal
=====================================
@@ -89,8 +89,6 @@ library
-- "ghc-bignum" and not "ghc-bignum-1.0".
ghc-options: -this-unit-id ghc-bignum
- include-dirs: include
-
if flag(gmp)
cpp-options: -DBIGNUM_GMP
other-modules:
=====================================
rts/PrimOps.cmm
=====================================
@@ -689,6 +689,14 @@ stg_newMutVarzh ( gcptr init )
return (mv);
}
+stg_swapMutVarzh ( gcptr mv, gcptr old )
+ /* MutVar# s a -> a -> State# s -> (# State#, a #) */
+{
+ W_ new;
+ (new) = prim %xchgW(mv+OFFSET_StgMutVar_var, old);
+ return (new);
+}
+
// RRN: To support the "ticketed" approach, we return the NEW rather
// than old value if the CAS is successful. This is received in an
// opaque form in the Haskell code, preventing the compiler from
=====================================
rts/include/Cmm.h
=====================================
@@ -193,8 +193,10 @@
#if SIZEOF_W == 4
#define cmpxchgW cmpxchg32
+#define xchgW xchg32
#elif SIZEOF_W == 8
#define cmpxchgW cmpxchg64
+#define xchgW xchg64
#endif
/* -----------------------------------------------------------------------------
=====================================
rts/js/rts.js
=====================================
@@ -365,14 +365,7 @@ function h$printReg(r) {
} else if(r.f.t === h$ct_blackhole && r.x) {
return ("blackhole: -> " + h$printReg({ f: r.x.x1, d: r.d1.x2 }) + ")");
} else {
- var iv = "";
- if(r.f.n === "integer-gmp:GHC.Integer.Type.Jp#" ||
- r.f.n === "integer-gmp:GHC.Integer.Type.Jn#") {
- iv = ' [' + r.d1.join(',') + '](' + h$ghcjsbn_showBase(r.d1, 10) + ')'
- } else if(r.f.n === "integer-gmp:GHC.Integer.Type.S#") {
- iv = ' (S: ' + r.d1 + ')';
- }
- return ((r.alloc ? r.alloc + ': ' : '') + r.f.n + " (" + h$closureTypeName(r.f.t) + ", " + r.f.a + ")" + iv);
+ return ((r.alloc ? r.alloc + ': ' : '') + r.f.n + " (" + h$closureTypeName(r.f.t) + ", " + r.f.a + ")");
}
} else if(typeof r === 'object') {
var res = h$collectProps(r);
@@ -536,14 +529,7 @@ function h$dumpStackTop(stack, start, sp) {
if(s.f.t === h$ct_blackhole && s.d1 && s.d1.x1 && s.d1.x1.n) {
h$log("stack[" + i + "] = blackhole -> " + s.d1.x1.n);
} else {
- var iv = "";
- if(s.f.n === "integer-gmp:GHC.Integer.Type.Jp#" ||
- s.f.n === "integer-gmp:GHC.Integer.Type.Jn#") {
- iv = ' [' + s.d1.join(',') + '](' + h$ghcjsbn_showBase(s.d1, 10) + ')'
- } else if(s.f.n === "integer-gmp:GHC.Integer.Type.S#") {
- iv = ' (S: ' + s.d1 + ')';
- }
- h$log("stack[" + i + "] = -> " + (s.alloc ? s.alloc + ': ' : '') + s.f.n + " (" + h$closureTypeName(s.f.t) + ", a: " + s.f.a + ")" + iv);
+ h$log("stack[" + i + "] = -> " + (s.alloc ? s.alloc + ': ' : '') + s.f.n + " (" + h$closureTypeName(s.f.t) + ", a: " + s.f.a + ")");
}
}
} else if(h$isInstanceOf(s,h$MVar)) {
=====================================
testsuite/tests/javascript/T23101.hs
=====================================
@@ -0,0 +1,22 @@
+
+foreign import javascript "(($1) => { return $1; })"
+ bool_id :: Bool -> Bool
+
+foreign import javascript "(($1) => { return !$1; })"
+ bool_not :: Bool -> Bool
+
+foreign import javascript "(($1) => { console.log($1); })"
+ bool_log :: Bool -> IO ()
+
+main :: IO ()
+main = do
+ bool_log True
+ bool_log False
+ bool_log (bool_id True)
+ bool_log (bool_id False)
+ bool_log (bool_not True)
+ bool_log (bool_not False)
+ print (bool_id True)
+ print (bool_id False)
+ print (bool_not True)
+ print (bool_not False)
=====================================
testsuite/tests/javascript/T23101.stdout
=====================================
@@ -0,0 +1,10 @@
+true
+false
+true
+false
+false
+true
+True
+False
+False
+True
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -0,0 +1,4 @@
+# These are JavaScript-specific tests
+setTestOpts(when(not(js_arch()),skip))
+
+test('T23101', normal, compile_and_run, [''])
=====================================
testsuite/tests/stranal/should_compile/T22997.hs
=====================================
@@ -0,0 +1,9 @@
+module T22997 where
+
+{-# OPAQUE trivial #-}
+trivial :: Int -> Int
+trivial = succ
+
+{-# OPAQUE pap #-}
+pap :: Integer -> Integer
+pap = (42 +)
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -88,3 +88,5 @@ test('EtaExpansion', normal, compile, [''])
test('T22039', normal, compile, [''])
# T22388: Should see $winteresting but not $wboring
test('T22388', [ grep_errmsg(r'^\S+\$w\S+') ], compile, ['-dsuppress-uniques -ddump-simpl'])
+# T22997: Just a panic that should not happen
+test('T22997', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d8c42f9531e51ab7a04236bf550bcc763e28b05...c69091a1d39351bb5695bf1ff9e0151dda7b6078
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d8c42f9531e51ab7a04236bf550bcc763e28b05...c69091a1d39351bb5695bf1ff9e0151dda7b6078
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/20230316/2e91c91a/attachment-0001.html>
More information about the ghc-commits
mailing list