[commit: ghc] master: Add a bizarre corner-case to cgExpr (Trac #9964) (9c78d09)
git at git.haskell.org
git at git.haskell.org
Fri Feb 20 08:48:01 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/9c78d09e344e97d2d5c37b9bb46e311a3cf031e2/ghc
>---------------------------------------------------------------
commit 9c78d09e344e97d2d5c37b9bb46e311a3cf031e2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Feb 20 08:49:32 2015 +0000
Add a bizarre corner-case to cgExpr (Trac #9964)
David Feuer managed to tickle a corner case in the
code generator. See Note [Scrutinising VoidRep]
in StgCmmExpr.
I rejigged the comments in that area of the code generator
Note [Dodgy unsafeCoerce 1]
Note [Dodgy unsafeCoerce 2]
but I can't say I fully understand them, alas.
>---------------------------------------------------------------
9c78d09e344e97d2d5c37b9bb46e311a3cf031e2
compiler/codeGen/StgCmmExpr.hs | 78 +++++++++++++++++--------
testsuite/tests/codeGen/should_compile/T9964.hs | 11 ++++
testsuite/tests/codeGen/should_compile/all.T | 1 +
3 files changed, 67 insertions(+), 23 deletions(-)
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 480cc33..7d2ef78 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -355,30 +355,59 @@ of Bool-returning primops was that tagToEnum# was added implicitly in the
codegen and then optimized away. Now the call to tagToEnum# is explicit
in the source code, which allows to optimize it away at the earlier stages
of compilation (i.e. at the Core level).
+
+Note [Scrutinising VoidRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this STG code:
+ f = \[s : State# RealWorld] ->
+ case s of _ -> blah
+This is very odd. Why are we scrutinising a state token? But it
+can arise with bizarre NOINLINE pragmas (Trac #9964)
+ crash :: IO ()
+ crash = IO (\s -> let {-# NOINLINE s' #-}
+ s' = s
+ in (# s', () #))
+
+Now the trouble is that 's' has VoidRep, and we do not bind void
+arguments in the environment; they don't live anywhere. See the
+calls to nonVoidIds in various places. So we must not look up
+'s' in the environment. Instead, just evaluate the RHS! Simple.
+
+Note [Dodgy unsafeCoerce 1]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ case (x :: MutVar# Int) |> co of (y :: HValue)
+ DEFAULT -> ...
+We want to gnerate an assignment
+ y := x
+We want to allow this assignment to be generated in the case when the
+types are compatible, because this allows some slightly-dodgy but
+occasionally-useful casts to be used, such as in RtClosureInspect
+where we cast an HValue to a MutVar# so we can print out the contents
+of the MutVar#. If instead we generate code that enters the HValue,
+then we'll get a runtime panic, because the HValue really is a
+MutVar#. The types are compatible though, so we can just generate an
+assignment.
+
+Note [Dodgy unsafeCoerce 2]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [ticket #3132]: we might be looking at a case of a lifted Id that
+was cast to an unlifted type. The Id will always be bottom, but we
+don't want the code generator to fall over here. If we just emit an
+assignment here, the assignment will be type-incorrect Cmm. Hence, we
+emit the usual enter/return code, (and because bottom must be
+untagged, it will be entered and the program will crash). The Sequel
+is a type-correct assignment, albeit bogus. The (dead) continuation
+loops; it would be better to invoke some kind of panic function here.
-}
+cgCase (StgApp v []) _ (PrimAlt _) alts
+ | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep]
+ , [(DEFAULT, _, _, rhs)] <- alts
+ = cgExpr rhs
- -- Note [ticket #3132]: we might be looking at a case of a lifted Id
- -- that was cast to an unlifted type. The Id will always be bottom,
- -- but we don't want the code generator to fall over here. If we
- -- just emit an assignment here, the assignment will be
- -- type-incorrect Cmm. Hence, we emit the usual enter/return code,
- -- (and because bottom must be untagged, it will be entered and the
- -- program will crash).
- -- The Sequel is a type-correct assignment, albeit bogus.
- -- The (dead) continuation loops; it would be better to invoke some kind
- -- of panic function here.
- --
- -- However, we also want to allow an assignment to be generated
- -- in the case when the types are compatible, because this allows
- -- some slightly-dodgy but occasionally-useful casts to be used,
- -- such as in RtClosureInspect where we cast an HValue to a MutVar#
- -- so we can print out the contents of the MutVar#. If we generate
- -- code that enters the HValue, then we'll get a runtime panic, because
- -- the HValue really is a MutVar#. The types are compatible though,
- -- so we can just generate an assignment.
cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
- | isUnLiftedType (idType v)
+ | isUnLiftedType (idType v) -- Note [Dodgy unsafeCoerce 1]
|| reps_compatible
= -- assignment suffices for unlifted types
do { dflags <- getDynFlags
@@ -392,7 +421,7 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
reps_compatible = idPrimRep v == idPrimRep bndr
cgCase scrut@(StgApp v []) _ (PrimAlt _) _
- = -- fail at run-time, not compile-time
+ = -- See Note [Dodgy unsafeCoerce 2]
do { dflags <- getDynFlags
; mb_cc <- maybeSaveCostCentre True
; _ <- withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
@@ -403,7 +432,9 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
; emit (mkBranch l)
; return AssignedDirectly
}
-{-
+
+{- Note [Handle seq#]
+~~~~~~~~~~~~~~~~~~~~~
case seq# a s of v
(# s', a' #) -> e
@@ -417,7 +448,8 @@ is the same as the return convention for just 'a')
-}
cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
- = -- handle seq#, same return convention as vanilla 'a'.
+ = -- Note [Handle seq#]
+ -- Use the same return convention as vanilla 'a'.
cgCase (StgApp a []) bndr alt_type alts
cgCase scrut bndr alt_type alts
diff --git a/testsuite/tests/codeGen/should_compile/T9964.hs b/testsuite/tests/codeGen/should_compile/T9964.hs
new file mode 100644
index 0000000..df15d47
--- /dev/null
+++ b/testsuite/tests/codeGen/should_compile/T9964.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedTuples #-}
+module T9964 where
+
+import GHC.Base
+
+crash :: IO ()
+crash = IO (\s ->
+ let
+ {-# NOINLINE s' #-}
+ s' = s
+ in (# s', () #))
diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T
index b571839..e06cead 100644
--- a/testsuite/tests/codeGen/should_compile/all.T
+++ b/testsuite/tests/codeGen/should_compile/all.T
@@ -29,3 +29,4 @@ test('T9329', [cmm_src], compile, [''])
test('debug', extra_clean(['debug.cmm']),
run_command,
['$MAKE -s --no-print-directory debug'])
+test('T9964', normal, compile, ['-O'])
More information about the ghc-commits
mailing list