[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