Deal with JoinIds before void types
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 10 Mar 2017 11:12:12 +0000 (11:12 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 10 Mar 2017 13:00:48 +0000 (13:00 +0000)
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.

compiler/codeGen/StgCmmExpr.hs
testsuite/tests/polykinds/T13394a.hs [new file with mode: 0644]
testsuite/tests/polykinds/all.T

index 395e8d6..39edd05 100644 (file)
@@ -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/T13394a.hs b/testsuite/tests/polykinds/T13394a.hs
new file mode 100644 (file)
index 0000000..e79bf79
--- /dev/null
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+module T13394 where
+
+import Data.ByteString
+
+newtype ProperName =
+  ProperName { runProperName :: ByteString
+               -- purescript actually uses the Text type, but this works
+               -- just as well for the purposes of illustrating the bug
+             }
+newtype ModuleName = ModuleName [ProperName]
+
+pattern TypeDataSymbol :: ModuleName
+pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data"]
index 8dd27b0..e8a0fac 100644 (file)
@@ -155,4 +155,5 @@ 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, [''])