Commit f714e6b6 authored by simonpj's avatar simonpj

[project @ 2003-12-30 16:29:17 by simonpj]

----------------------------
        Re-do kind inference (again)
	----------------------------

   [WARNING: interface file binary representation has
   (as usual) changed slightly; recompile your libraries!]

Inspired by the lambda-cube, for some time GHC has used
	type Kind = Type
That is, kinds were represented by the same data type as types.

But GHC also supports unboxed types and unboxed tuples, and these
complicate the kind system by requiring a sub-kind relationship.
Notably, an unboxed tuple is acceptable as the *result* of a
function but not as an *argument*.  So we have the following setup:

		 ?
		/ \
	       /   \
	      ??   (#)
	     /  \
            *   #

where	*    [LiftedTypeKind]   means a lifted type
	#    [UnliftedTypeKind] means an unlifted type
	(#)  [UbxTupleKind]     means unboxed tuple
	??   [ArgTypeKind]      is the lub of *,#
	?    [OpenTypeKind]	means any type at all

In particular:

  error :: forall a:?. String -> a
  (->)  :: ?? -> ? -> *
  (\(x::t) -> ...)	Here t::?? (i.e. not unboxed tuple)

All this has beome rather difficult to accommodate with Kind=Type, so this
commit splits the two.

  * Kind is a distinct type, defined in types/Kind.lhs

  * IfaceType.IfaceKind disappears: we just re-use Kind.Kind

  * TcUnify.unifyKind is a distinct unifier for kinds

  * TyCon no longer needs KindCon and SuperKindCon variants

  * TcUnify.zapExpectedType takes an expected Kind now, so that
    in TcPat.tcMonoPatBndr we can express that the bound variable
    must have an argTypeKind (??).

The big change is really that kind inference is much more systematic and
well behaved.  In particular, a kind variable can unify only with a
"simple kind", which is built from * and (->).  This deals neatly
with awkward questions about how we can combine sub-kinding with type
inference.

Lots of small consequential changes, especially to the kind-checking
plumbing in TcTyClsDecls.  (We played a bit fast and loose before, and
now we have to be more honest, in particular about how kind inference
works for type synonyms.  They can have kinds like (* -> #), so

This cures two long-standing SourceForge bugs

* 753777 (tcfail115.hs), which used erroneously to pass,
  but crashed in the code generator
      type T a = Int -> (# Int, Int #)
      f :: T a -> T a
      f t = \x -> case t x of r -> r

* 753780 (tc167.hs), which used erroneously to fail
      f :: (->) Int# Int#


Still, the result is not entirely satisfactory.  In particular

* The error message from tcfail115 is pretty obscure

* SourceForge bug 807249 (Instance match failure on openTypeKind)
  is not fixed.  Alas.
parent 9e90a28e
......@@ -8,10 +8,10 @@ module Id (
Id, DictId,
-- Simple construction
mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
mkWorkerId,
mkWorkerId, mkExportedLocalId,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
......@@ -19,7 +19,7 @@ module Id (
recordSelectorFieldLabel,
-- Modifying an Id
setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
setIdName, setIdUnique, Id.setIdType, setIdLocalExported, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
......@@ -83,12 +83,12 @@ import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId,
setIdName, setVarType, setIdUnique, setIdLocalExported,
setIdName, setIdType, setIdUnique, setIdLocalExported,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
globalIdDetails, setGlobalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
import Type ( Type, typePrimRep, addFreeTyVars, seqType)
import IdInfo
......@@ -146,6 +146,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
mkSpecPragmaId :: Name -> Type -> Id
mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
mkExportedLocalId :: Name -> Type -> Id
mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
\end{code}
......@@ -209,7 +212,7 @@ mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
\begin{code}
setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
setIdType id ty = seqType ty `seq` Var.setIdType id (addFreeTyVars ty)
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
......
......@@ -69,8 +69,8 @@ import DataCon ( DataCon, DataConIds(..),
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId,
mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported,
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
mkTemplateLocal, idName
)
import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
......@@ -740,8 +740,7 @@ BUT make sure they are *exported* LocalIds (setIdLocalExported) so
that they aren't discarded by the occurrence analyser.
\begin{code}
mkDefaultMethodId dm_name ty
= setIdLocalExported (mkLocalId dm_name ty)
mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
......@@ -751,7 +750,7 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> Id
mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
= setIdLocalExported (mkLocalId dfun_name dfun_ty)
= mkExportedLocalId dfun_name dfun_ty
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
......
......@@ -11,8 +11,8 @@ module Name (
-- The Name type
Name, -- Abstract
mkInternalName, mkSystemName,
mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName,
mkIPName,
mkSystemNameEncoded, mkSysTvName,
mkFCallName, mkIPName,
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
......@@ -212,10 +212,10 @@ mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkSysOccFS varName fs,
n_loc = noSrcLoc }
mkSystemTvNameEncoded :: Unique -> EncodedFS -> Name
mkSystemTvNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkSysOccFS tvName fs,
n_loc = noSrcLoc }
mkSysTvName :: Unique -> EncodedFS -> Name
mkSysTvName uniq fs = Name { n_uniq = uniq, n_sort = System,
n_occ = mkSysOccFS tvName fs,
n_loc = noSrcLoc }
mkFCallName :: Unique -> EncodedString -> Name
-- The encoded string completely describes the ccall
......
......@@ -38,20 +38,20 @@ module RdrName (
#include "HsVersions.h"
import OccName ( NameSpace, tcName, varName,
OccName, UserFS, EncodedFS,
mkSysOccFS, setOccNameSpace,
mkOccFS, mkVarOcc, occNameFlavour,
import OccName ( NameSpace, varName,
OccName, UserFS,
setOccNameSpace,
mkOccFS, occNameFlavour,
isDataOcc, isTvOcc, isTcOcc,
OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv,
elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv,
occEnvElts
)
import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS )
import Module ( ModuleName, mkModuleNameFS )
import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe,
nameOccName, isExternalName, nameSrcLoc )
import Maybes ( seqMaybe )
import SrcLoc ( SrcLoc, isGoodSrcLoc, SrcSpan )
import SrcLoc ( isGoodSrcLoc, SrcSpan )
import BasicTypes( DeprecTxt )
import Outputable
import Util ( thenCmp )
......
......@@ -5,49 +5,47 @@
\begin{code}
module Var (
Var, VarDetails, -- Abstract
varName, varUnique, varInfo, varType,
setVarName, setVarUnique, setVarType, setVarOcc,
Var,
varName, varUnique,
setVarName, setVarUnique, setVarOcc,
-- TyVars
TyVar,
TyVar, mkTyVar, mkTcTyVar,
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
mkTyVar, mkSysTyVar,
mkMutTyVar, mutTyVarRef, makeTyVarImmutable,
tcTyVarRef, tcTyVarDetails,
-- Ids
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdInfo, lazySetIdInfo,
setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo,
setIdLocalExported, zapSpecPragmaId,
globalIdDetails, setGlobalIdDetails,
mkLocalId, mkGlobalId, mkSpecPragmaId,
mkLocalId, mkExportedLocalId, mkSpecPragmaId,
mkGlobalId,
isTyVar, isMutTyVar, mutTyVarDetails,
isId, isLocalVar, isLocalId,
isTyVar, isTcTyVar, isId, isLocalVar, isLocalId,
isGlobalId, isExportedId, isSpecPragmaId,
mustHaveLocalBinding
) where
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TypeRep( Type )
import {-# SOURCE #-} TcType( TyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId,
IdInfo, seqIdInfo )
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique,
mkSystemTvNameEncoded,
setNameUnique, setNameOcc, nameUnique
)
import Kind ( Kind )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
import DATA_IOREF ( IORef )
import DATA_IOREF
\end{code}
......@@ -65,34 +63,33 @@ in its @VarDetails@.
\begin{code}
data Var
= Var {
= TyVar {
varName :: !Name,
realUnique :: FastInt, -- Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
varType :: Type,
varDetails :: VarDetails,
varInfo :: IdInfo -- Only used for Ids at the moment
}
data VarDetails
= LocalId -- Used for locally-defined Ids (see NOTE below)
LocalIdDetails
| GlobalId -- Used for imported Ids, dict selectors etc
GlobalIdDetails
| TyVar
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
TyVarDetails
-- TODO: the IORef should be unboxed here, but we don't want to unbox
-- the Name above.
-- For a long time I tried to keep mutable Vars statically
-- type-distinct from immutable Vars, but I've finally given
-- up. It's just too painful. After type checking there are
-- no MutTyVars left, but there's no static check of that
-- fact.
tyVarKind :: Kind }
| TcTyVar { -- Used only during type inference
varName :: !Name, -- Could we get away without a Name?
realUnique :: FastInt,
tyVarKind :: Kind,
tcTyVarRef :: IORef (Maybe Type),
tcTyVarDetails :: TyVarDetails }
| GlobalId { -- Used for imported Ids, dict selectors etc
varName :: !Name,
realUnique :: FastInt,
idType :: Type,
idInfo :: IdInfo,
gblDetails :: GlobalIdDetails }
| LocalId { -- Used for locally-defined Ids (see NOTE below)
varName :: !Name,
realUnique :: FastInt,
idType :: Type,
idInfo :: IdInfo,
lclDetails :: LocalIdDetails }
data LocalIdDetails
= NotExported -- Not exported
......@@ -143,23 +140,21 @@ instance Ord Var where
\begin{code}
varUnique :: Var -> Unique
varUnique (Var {realUnique = uniq}) = mkUniqueGrimily (iBox uniq)
varUnique var = mkUniqueGrimily (iBox (realUnique var))
setVarUnique :: Var -> Unique -> Var
setVarUnique var@(Var {varName = name}) uniq
= var {realUnique = getKey# uniq,
varName = setNameUnique name uniq}
setVarUnique var uniq
= var { realUnique = getKey# uniq,
varName = setNameUnique (varName var) uniq }
setVarName :: Var -> Name -> Var
setVarName var new_name
= var { realUnique = getKey# (getUnique new_name), varName = new_name }
= var { realUnique = getKey# (getUnique new_name),
varName = new_name }
setVarOcc :: Var -> OccName -> Var
setVarOcc var new_occ
= var { varName = setNameOcc (varName var) new_occ }
setVarType :: Var -> Type -> Var
setVarType var ty = var {varType = ty}
\end{code}
......@@ -171,11 +166,8 @@ setVarType var ty = var {varType = ty}
\begin{code}
type TyVar = Var
\end{code}
\begin{code}
tyVarName = varName
tyVarKind = varType
setTyVarUnique = setVarUnique
setTyVarName = setVarName
......@@ -183,40 +175,19 @@ setTyVarName = setVarName
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = Var { varName = name
, realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkTyVar" (ppr name)
mkTyVar name kind = TyVar { varName = name
, realUnique = getKey# (nameUnique name)
, tyVarKind = kind
}
mkSysTyVar :: Unique -> Kind -> TyVar
mkSysTyVar uniq kind = Var { varName = name
, realUnique = getKey# uniq
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkSysTyVar" (ppr name)
}
where
name = mkSystemTvNameEncoded uniq FSLIT("t")
mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
mkMutTyVar name kind details ref
= Var { varName = name
, realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = MutTyVar ref details
, varInfo = pprPanic "newMutTyVar" (ppr name)
mkTcTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
mkTcTyVar name kind details ref
= TcTyVar { varName = name,
realUnique = getKey# (nameUnique name),
tyVarKind = kind,
tcTyVarRef = ref,
tcTyVarDetails = details
}
mutTyVarRef :: TyVar -> IORef (Maybe Type)
mutTyVarRef (Var {varDetails = MutTyVar loc _}) = loc
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
mutTyVarDetails :: TyVar -> TyVarDetails
mutTyVarDetails (Var {varDetails = MutTyVar _ details}) = details
\end{code}
......@@ -235,9 +206,7 @@ type DictId = Id
\begin{code}
idName = varName
idType = varType
idUnique = varUnique
idInfo = varInfo
setIdUnique :: Id -> Unique -> Id
setIdUnique = setVarUnique
......@@ -245,33 +214,41 @@ setIdUnique = setVarUnique
setIdName :: Id -> Name -> Id
setIdName = setVarName
setIdType :: Id -> Type -> Id
setIdType id ty = id {idType = ty}
setIdLocalExported :: Id -> Id
setIdLocalExported id = id { varDetails = LocalId Exported }
-- It had better be a LocalId already
setIdLocalExported id = id { lclDetails = Exported }
setGlobalIdDetails :: Id -> GlobalIdDetails -> Id
-- It had better be a GlobalId already
setGlobalIdDetails id details = id { gblDetails = details }
zapSpecPragmaId :: Id -> Id
zapSpecPragmaId id
= case varDetails id of
LocalId SpecPragma -> id { varDetails = LocalId NotExported }
other -> id
zapSpecPragmaId id
| isSpecPragmaId id = id {lclDetails = NotExported}
| otherwise = id
lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo var info = var {varInfo = info}
lazySetIdInfo id info = id {idInfo = info}
setIdInfo :: Id -> IdInfo -> Id
setIdInfo var info = seqIdInfo info `seq` var {varInfo = info}
setIdInfo id info = seqIdInfo info `seq` id {idInfo = info}
-- Try to avoid spack leaks by seq'ing
modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo fn var@(Var {varInfo = info})
= seqIdInfo new_info `seq` var {varInfo = new_info}
modifyIdInfo fn id
= seqIdInfo new_info `seq` id {idInfo = new_info}
where
new_info = fn info
new_info = fn (idInfo id)
-- maybeModifyIdInfo tries to avoid unnecesary thrashing
maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of
Nothing -> var
Just new_info -> var {varInfo = new_info}
maybeModifyIdInfo fn id
= case fn (idInfo id) of
Nothing -> id
Just new_info -> id {idInfo = new_info}
\end{code}
%************************************************************************
......@@ -281,56 +258,57 @@ maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of
%************************************************************************
\begin{code}
mkId :: Name -> Type -> VarDetails -> IdInfo -> Id
mkId name ty details info
= Var { varName = name,
realUnique = getKey# (nameUnique name), -- Cache the unique
varType = ty,
varDetails = details,
varInfo = info }
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info
= GlobalId { varName = name,
realUnique = getKey# (nameUnique name), -- Cache the unique
idType = ty,
gblDetails = details,
idInfo = info }
mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id
mk_local_id name ty details info
= LocalId { varName = name,
realUnique = getKey# (nameUnique name), -- Cache the unique
idType = ty,
lclDetails = details,
idInfo = info }
mkLocalId :: Name -> Type -> IdInfo -> Id
mkLocalId name ty info = mkId name ty (LocalId NotExported) info
mkLocalId name ty info = mk_local_id name ty NotExported info
mkSpecPragmaId :: Name -> Type -> IdInfo -> Id
mkSpecPragmaId name ty info = mkId name ty (LocalId SpecPragma) info
mkExportedLocalId :: Name -> Type -> IdInfo -> Id
mkExportedLocalId name ty info = mk_local_id name ty Exported info
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info = mkId name ty (GlobalId details) info
mkSpecPragmaId :: Name -> Type -> IdInfo -> Id
mkSpecPragmaId name ty info = mk_local_id name ty SpecPragma info
\end{code}
\begin{code}
isTyVar, isMutTyVar :: Var -> Bool
isTyVar, isTcTyVar :: Var -> Bool
isId, isLocalVar, isLocalId :: Var -> Bool
isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool
mustHaveLocalBinding :: Var -> Bool
isTyVar var = case varDetails var of
TyVar -> True
MutTyVar _ _ -> True
other -> False
isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
isTyVar other = False
isMutTyVar (Var {varDetails = MutTyVar _ _}) = True
isMutTyVar other = False
isTcTyVar (TcTyVar {}) = True
isTcTyVar other = False
isId (LocalId {}) = True
isId (GlobalId {}) = True
isId other = False
isId var = case varDetails var of
LocalId _ -> True
GlobalId _ -> True
other -> False
isLocalId var = case varDetails var of
LocalId _ -> True
other -> False
isLocalId (LocalId {}) = True
isLocalId other = False
-- isLocalVar returns True for type variables as well as local Ids
-- These are the variables that we need to pay attention to when finding free
-- variables, or doing dependency analysis.
isLocalVar var = case varDetails var of
LocalId _ -> True
TyVar -> True
MutTyVar _ _ -> True
other -> False
isLocalVar (GlobalId {}) = False
isLocalVar other = True
-- mustHaveLocalBinding returns True of Ids and TyVars
-- that must have a binding in this module. The converse
......@@ -339,29 +317,26 @@ isLocalVar var = case varDetails var of
-- because it's only used for assertions
mustHaveLocalBinding var = isLocalVar var
isGlobalId var = case varDetails var of
GlobalId _ -> True
other -> False
isGlobalId (GlobalId {}) = True
isGlobalId other = False
-- isExportedId means "don't throw this away"
isExportedId var = case varDetails var of
LocalId Exported -> True
LocalId SpecPragma -> True
GlobalId _ -> True
other -> False
isSpecPragmaId var = case varDetails var of
LocalId SpecPragma -> True
other -> False
isExportedId (GlobalId {}) = True
isExportedId (LocalId {lclDetails = details})
= case details of
Exported -> True
SpecPragma -> True
other -> False
isExportedId other = False
isSpecPragmaId (LocalId {lclDetails = SpecPragma}) = True
isSpecPragmaId other = False
\end{code}
\begin{code}
globalIdDetails :: Var -> GlobalIdDetails
-- Works OK on local Ids too, returning notGlobalId
globalIdDetails var = case varDetails var of
GlobalId details -> details
other -> notGlobalId
setGlobalIdDetails :: Id -> GlobalIdDetails -> Id
setGlobalIdDetails id details = id { varDetails = GlobalId details }
globalIdDetails (GlobalId {gblDetails = details}) = details
globalIdDetails other = notGlobalId
\end{code}
......@@ -66,7 +66,6 @@ import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule,
extendModuleEnvList, extendModuleEnv,
moduleNameUserString,
ModLocation(..) )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import GetImports
import UniqFM
import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
......@@ -85,6 +84,7 @@ import DATA_IOREF ( readIORef )
import HscMain ( hscThing, hscStmt, hscTcExpr )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import Name ( Name )
import NameEnv
import Id ( idType )
......
......@@ -32,7 +32,7 @@ import Type ( Type, tyVarsOfType, eqType,
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
hasMoreBoxityInfo
isSubKind
)
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
......@@ -333,7 +333,7 @@ lintTyApp ty arg_ty
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
if argty_kind `hasMoreBoxityInfo` tyvar_kind
if argty_kind `isSubKind` tyvar_kind
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
......@@ -406,8 +406,8 @@ lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
= addLoc (CaseAlt alt) (
mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
(mkUnboxedTupleMsg arg)) args `seqL`
mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
(mkUnboxedTupleMsg arg)) args `seqL`
addInScopeVars args (
......
......@@ -25,6 +25,7 @@ import CoreSyn
import Var
import IdInfo
import Id ( idUnfolding )
import Kind
import CoreTidy ( tidyExpr )
import VarEnv ( emptyTidyEnv )
import Literal
......@@ -118,14 +119,14 @@ make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_vbind :: Var -> C.Vbind
make_vbind v = (make_var_id (Var.varName v), make_ty (varType v))
make_vbind v = (make_var_id (Var.varName v), make_ty (idType v))
make_vdef :: CoreBind -> C.Vdefg
make_vdef b =
case b of
NonRec v e -> C.Nonrec (f (v,e))
Rec ves -> C.Rec (map f ves)
where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e)
where f (v,e) = (make_var_id (Var.varName v), make_ty (idType v),make_exp e)
-- Top level bindings are unqualified now
make_exp :: CoreExpr -> C.Exp
......@@ -133,7 +134,7 @@ make_exp (Var v) =
case globalIdDetails v of
-- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
-- DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (idType v))
FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
_ -> C.Var (make_var_qid (Var.varName v))
make_exp (Lit (l@(MachLabel s _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations"
......@@ -205,10 +206,10 @@ make_ty (NoteTy _ t) = make_ty t
make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k | k `eqKind` liftedTypeKind = C.Klifted
make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
make_kind k | k `eqKind` openTypeKind = C.Kopen
make_kind (FunKind k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind LiftedTypeKind = C.Klifted
make_kind UnliftedTypeKind = C.Kunlifted
make_kind OpenTypeKind = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"
{- Id generation. -}
......
......@@ -23,7 +23,7 @@ import TysWiredIn
import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc, Located(..), getLoc, unLoc, noLoc )
import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc )
import UniqSet
import Util ( takeList, splitAtList, notNull )
import Outputable
......
......@@ -39,7 +39,6 @@ import CoreFVs ( ruleRhsFreeVars )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
mkWarnMsg, errorsFound, WarnMsg )
import Outputable