diff options
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/polykinds/T13394a.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/polykinds/all.T | 1 |
3 files changed, 20 insertions, 3 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 395e8d6fa6..39edd05a8e 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/T13394a.hs b/testsuite/tests/polykinds/T13394a.hs new file mode 100644 index 0000000000..e79bf79d5b --- /dev/null +++ b/testsuite/tests/polykinds/T13394a.hs @@ -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"] diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index 8dd27b0377..e8a0facaea 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -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, ['']) |