[commit: ghc] ghc-8.0: Fix bytecode gen to deal with rep-polymorphism (a8d4759)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/a8d4759eb7add57bcee29cc17023f5e900c44f44/ghc

>---------------------------------------------------------------

commit a8d4759eb7add57bcee29cc17023f5e900c44f44
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu May 26 14:20:29 2016 +0100

    Fix bytecode gen to deal with rep-polymorphism
    
    When faced runtime-rep-polymorphic code from a pattern-synonym
    matcher, the bytecode generator was treating the result as lifted,
    which it isn't.  The fix is just to treat those rep-polymorphic
    continuations like unlifted types, and add a dummy arg.
    
    Trac #12007 is a case in point.
    
    (cherry picked from commit 0f1e315b9274725c4a2c975f4d06a5c956cf5385)


>---------------------------------------------------------------

a8d4759eb7add57bcee29cc17023f5e900c44f44
 compiler/ghci/ByteCodeGen.hs               | 37 ++++++++++++++++++++----------
 testsuite/tests/ghci/scripts/T12007.hs     |  7 ++++++
 testsuite/tests/ghci/scripts/T12007.script |  3 +++
 testsuite/tests/ghci/scripts/T12007.stdout |  1 +
 testsuite/tests/ghci/scripts/all.T         |  1 +
 5 files changed, 37 insertions(+), 12 deletions(-)

diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index bf11edb..9a78054 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -31,6 +31,7 @@ import Literal
 import PrimOp
 import CoreFVs
 import Type
+import Kind            ( isLiftedTypeKind )
 import DataCon
 import TyCon
 import Util
@@ -486,35 +487,47 @@ schemeE d s p (AnnLet binds (_,body)) = do
      thunk_codes <- sequence compile_binds
      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
--- introduce a let binding for a ticked case expression. This rule
+-- Introduce a let binding for a ticked case expression. This rule
 -- *should* only fire when the expression was not already let-bound
 -- (the code gen for let bindings should take care of that).  Todo: we
 -- call exprFreeVars on a deAnnotated expression, this may not be the
 -- best way to calculate the free vars but it seemed like the least
 -- intrusive thing to do
 schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-   = if isUnliftedType ty
-        then do
-          -- If the result type is unlifted, then we must generate
+   | isLiftedTypeKind (typeKind ty)
+   = do   id <- newId ty
+          -- Todo: is emptyVarSet correct on the next line?
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
+          schemeE d s p letExp
+
+   | otherwise
+   = do   -- If the result type is not definitely lifted, then we must generate
           --   let f = \s . tick<n> e
           --   in  f realWorld#
           -- When we stop at the breakpoint, _result will have an unlifted
           -- type and hence won't be bound in the environment, but the
           -- breakpoint will otherwise work fine.
+          --
+          -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where
+          --    r :: RuntimeRep is a variable. This can happen in the
+          --    continuations for a pattern-synonym matcher
+          --    match = /\(r::RuntimeRep) /\(a::TYPE r).
+          --            \(k :: Int -> a) \(v::T).
+          --            case v of MkV n -> k n
+          -- Here (k n) :: a :: Type r, so we don't know if it's lifted
+          -- or not; but that should be fine provided we add that void arg.
+
           id <- newId (mkFunTy realWorldStatePrimTy ty)
           st <- newId realWorldStatePrimTy
           let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
                               (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
                                                     (emptyDVarSet, AnnVar realWorldPrimId)))
           schemeE d s p letExp
-        else do
-          id <- newId ty
-          -- Todo: is emptyVarSet correct on the next line?
-          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
-          schemeE d s p letExp
-   where exp' = deAnnotate' exp
-         fvs  = exprFreeVarsDSet exp'
-         ty   = exprType exp'
+
+   where
+     exp' = deAnnotate' exp
+     fvs  = exprFreeVarsDSet exp'
+     ty   = exprType exp'
 
 -- ignore other kinds of tick
 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
diff --git a/testsuite/tests/ghci/scripts/T12007.hs b/testsuite/tests/ghci/scripts/T12007.hs
new file mode 100644
index 0000000..c678727
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12007.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T12007 where
+
+data Foo a = Foo a a
+
+pattern A a1 a2 = Foo a1 a2
+pattern B a1 a2 = A a1 a2
diff --git a/testsuite/tests/ghci/scripts/T12007.script b/testsuite/tests/ghci/scripts/T12007.script
new file mode 100644
index 0000000..8e6a27a
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12007.script
@@ -0,0 +1,3 @@
+:l T12007
+let f (B x y) = (y,x)
+f (Foo 'c' 'd')
diff --git a/testsuite/tests/ghci/scripts/T12007.stdout b/testsuite/tests/ghci/scripts/T12007.stdout
new file mode 100644
index 0000000..a6a2425
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T12007.stdout
@@ -0,0 +1 @@
+('d','c')
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 47a775b..a0b5f1b 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -248,3 +248,4 @@ test('T11524a', normal, ghci_script, ['T11524a.script'])
 test('T11456', normal, ghci_script, ['T11456.script'])
 test('TypeAppData', normal, ghci_script, ['TypeAppData.script'])
 test('T11376', normal, ghci_script, ['T11376.script'])
+test('T12007', normal, ghci_script, ['T12007.script'])