Make 'undefined' have the magical type 'forall (a:OpenKind).a'

This fixes Trac #7888, where the user wanted to use 'undefined' in a
context that needed ((forall a. a->a) -> Int).  We allow OpenKind
unification variables to be instantiate with polytypes (or unboxed
types), hence the change.

'error' has always been like this; this change simply extends
the special treatment to 'undefined'.  It's still magical;
you can't define your own wrapper for 'error' and get the
same behaviour.  Really just a convenience hack.

2 files changed, 39 insertions, 14 deletions

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 4cc199853b..c6fc2be21f 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -53,7 +53,8 @@ module MkCore (
     	mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
     	rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
     	nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
-    	pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID
+    	pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
+        uNDEFINED_ID, undefinedName
     ) where
 
 #include "HsVersions.h"
@@ -659,6 +660,9 @@ errorIds
                   -- import its type from the interface file; we just get
                   -- the Id defined here.  Which has an 'open-tyvar' type.
 
+      uNDEFINED_ID,   -- Ditto for 'undefined'. The big deal is to give it
+                      -- an 'open-tyvar' type.
+
       rUNTIME_ERROR_ID,
       iRREFUT_PAT_ERROR_ID,
       nON_EXHAUSTIVE_GUARDS_ERROR_ID,
@@ -700,7 +704,7 @@ nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
 aBSENT_ERROR_ID                 = mkRuntimeErrorId absentErrorName
 
 mkRuntimeErrorId :: Name -> Id
-mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
 
 runtimeErrorTy :: Type
 -- The runtime error Ids take a UTF8-encoded string as argument
@@ -712,15 +716,33 @@ errorName :: Name
 errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
 
 eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id errorName errorTy
+eRROR_ID = pc_bottoming_Id1 errorName errorTy
 
-errorTy  :: Type
+errorTy  :: Type   -- See Note [Error and friends have an "open-tyvar" forall]
 errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
-    -- Notice the openAlphaTyVar.  It says that "error" can be applied
-    -- to unboxed as well as boxed types.  This is OK because it never
-    -- returns, so the return type is irrelevant.
+
+undefinedName :: Name
+undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID
+
+uNDEFINED_ID :: Id
+uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
+
+undefinedTy  :: Type   -- See Note [Error and friends have an "open-tyvar" forall]
+undefinedTy  = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
 \end{code}
 
+Note [Error and friends have an "open-tyvar" forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'error' and 'undefined' have types 
+        error     :: forall (a::OpenKind). String -> a
+        undefined :: forall (a::OpenKind). a
+Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that
+"error" can be instantiated at 
+  * unboxed as well as boxed types
+  * polymorphic types
+This is OK because it never returns, so the return type is irrelevant.
+See Note [OpenTypeKind accepts foralls] in TcUnify.
+
 
 %************************************************************************
 %*                                                                      *
@@ -729,9 +751,9 @@ errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy
 %************************************************************************
 
 \begin{code}
-pc_bottoming_Id :: Name -> Type -> Id
+pc_bottoming_Id1 :: Name -> Type -> Id
 -- Function of arity 1, which diverges after being given one argument
-pc_bottoming_Id name ty
+pc_bottoming_Id1 name ty
  = mkVanillaGlobalWithInfo name ty bottoming_info
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo`    strict_sig
@@ -749,5 +771,13 @@ pc_bottoming_Id name ty
 
     strict_sig = mkStrictSig (mkTopDmdType [evalDmd] botRes)
     -- These "bottom" out, no matter what their arguments
+
+pc_bottoming_Id0 :: Name -> Type -> Id
+-- Same but arity zero
+pc_bottoming_Id0 name ty
+ = mkVanillaGlobalWithInfo name ty bottoming_info
+ where
+    bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
+    strict_sig = mkStrictSig (mkTopDmdType [] botRes)
 \end{code}
 
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 19acf488e0..09835fb34e 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -798,10 +798,6 @@ stringTyConName         = tcQual  gHC_BASE (fsLit "String") stringTyConKey
 inlineIdName :: Name
 inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
 
--- The 'undefined' function. Used by supercompilation.
-undefinedName :: Name
-undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey
-
 -- Base classes (Eq, Ord, Functor)
 fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
 eqClassName       = clsQual  gHC_CLASSES (fsLit "Eq")      eqClassKey
@@ -1689,7 +1685,6 @@ checkDotnetResNameIdKey       = mkPreludeMiscIdUnique 154
 
 undefinedKey :: Unique
 undefinedKey                  = mkPreludeMiscIdUnique 155
-
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own