[commit: ghc] ghc-8.2: Deal with JoinIds before void types (704cbae)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/704cbae29ee09431cfbd6b1566a6ec6856f125fc/ghc

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

commit 704cbae29ee09431cfbd6b1566a6ec6856f125fc
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Mar 10 11:12:12 2017 +0000

    Deal with JoinIds before void types
    
    Trac #13394, comment:4 showed up another place where we were testing
    for the representation of of a type; and it turned out to be a JoinId
    which can be rep-polymorphic.
    
    Just putting the test in the right places solves this easily.
    
    (cherry picked from commit bc0f3abd0914808e33f84229818ab90842611bdd)


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

704cbae29ee09431cfbd6b1566a6ec6856f125fc
 compiler/codeGen/StgCmmExpr.hs                      | 7 ++++---
 testsuite/tests/polykinds/{T13394.hs => T13394a.hs} | 2 +-
 testsuite/tests/polykinds/all.T                     | 1 +
 3 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 395e8d6..39edd05 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -701,7 +701,6 @@ cgConApp con stg_args
         ; emitReturn [idInfoToAmode idinfo] }
 
 cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
-cgIdApp fun_id [] | isVoidTy (idType fun_id) = emitReturn []
 cgIdApp fun_id args = do
     dflags         <- getDynFlags
     fun_info       <- getCgIdInfo fun_id
@@ -719,9 +718,11 @@ cgIdApp fun_id args = do
         v_args      = length $ filter (isVoidTy . stgArgType) args
         node_points dflags = nodeMustPointToIt dflags lf_info
     case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of
-
             -- A value in WHNF, so we can just return it.
-        ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
+        ReturnIt
+          | isVoidTy (idType fun_id) -> emitReturn []
+          | otherwise                -> emitReturn [fun]
+          -- ToDo: does ReturnIt guarantee tagged?
 
         EnterIt -> ASSERT( null args )  -- Discarding arguments
                    emitEnter fun
diff --git a/testsuite/tests/polykinds/T13394.hs b/testsuite/tests/polykinds/T13394a.hs
similarity index 84%
copy from testsuite/tests/polykinds/T13394.hs
copy to testsuite/tests/polykinds/T13394a.hs
index 88c482a..e79bf79 100644
--- a/testsuite/tests/polykinds/T13394.hs
+++ b/testsuite/tests/polykinds/T13394a.hs
@@ -12,4 +12,4 @@ newtype ProperName =
 newtype ModuleName = ModuleName [ProperName]
 
 pattern TypeDataSymbol :: ModuleName
-pattern TypeDataSymbol = ModuleName [ProperName "Type"]
+pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data"]
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index f88f4a2..5e1678f 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/testsuite/tests/polykinds/all.T
@@ -156,6 +156,7 @@ test('T12718', normal, compile, [''])
 test('T12444', normal, compile_fail, [''])
 test('T12885', normal, compile, [''])
 test('T13267', normal, compile_fail, [''])
+test('T13394a', normal, compile, [''])
 test('T13394', normal, compile, [''])
 test('T13371', normal, compile, [''])
 test('T13393', normal, compile_fail, [''])