Commit 23f40f0e authored by simonpj's avatar simonpj

[project @ 2004-09-30 10:35:15 by simonpj]

------------------------------------
	Add Generalised Algebraic Data Types
	------------------------------------

This rather big commit adds support for GADTs.  For example,

    data Term a where
 	  Lit :: Int -> Term Int
	  App :: Term (a->b) -> Term a -> Term b
	  If  :: Term Bool -> Term a -> Term a
	  ..etc..

    eval :: Term a -> a
    eval (Lit i) = i
    eval (App a b) = eval a (eval b)
    eval (If p q r) | eval p    = eval q
    		    | otherwise = eval r


Lots and lots of of related changes throughout the compiler to make
this fit nicely.

One important change, only loosely related to GADTs, is that skolem
constants in the typechecker are genuinely immutable and constant, so
we often get better error messages from the type checker.  See
TcType.TcTyVarDetails.

There's a new module types/Unify.lhs, which has purely-functional
unification and matching for Type. This is used both in the typechecker
(for type refinement of GADTs) and in Core Lint (also for type refinement).
parent 9b6858cb
......@@ -64,23 +64,16 @@ name = Util.global (value) :: IORef (ty); \
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
#define ASSERTM(e) ASSERT(e) do
#define ASSERTM(mbool) do { bool <- mbool; ASSERT(bool) return () }
#define ASSERTM2(mbool,msg) do { bool <- mbool; ASSERT2(bool,msg) return () }
#else
#define ASSERT(e) if False then error "ASSERT" else
#define ASSERT2(e,msg) if False then error "ASSERT2" else
#define ASSERTM(e)
#define ASSERTM2(e)
#define WARN(e,msg) if False then error "WARN" else
#endif
-- temporary usage assertion control KSW 2000-10
#ifdef DO_USAGES
#define UASSERT(e) ASSERT(e)
#define UASSERT2(e,msg) ASSERT2(e,msg)
#else
#define UASSERT(e)
#define UASSERT2(e,msg)
#endif
-- This #ifndef lets us switch off the "import FastString"
-- when compiling FastString itself
#ifndef COMPILING_FAST_STRING
......
*** unexpected failure for jtod_circint(opt)
New back end thoughts
-----------------------------------------------------------------------------
......
......@@ -2,4 +2,4 @@ module DataCon where
data DataCon
dataConName :: DataCon -> Name.Name
isExistentialDataCon :: DataCon -> GHC.Base.Bool
isVanillaDataCon :: DataCon -> GHC.Base.Bool
......@@ -9,39 +9,37 @@ module DataCon (
ConTag, fIRST_TAG,
mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
dataConRepArgTys, dataConTheta,
dataConTyVars, dataConStupidTheta,
dataConArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConStrictMarks, dataConExStricts,
dataConSourceArity, dataConRepArity,
dataConNumInstArgs, dataConIsInfix,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
isExistentialDataCon, classDataCon, dataConExistentialTyVars,
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
splitProductType_maybe, splitProductType,
) where
#include "HsVersions.h"
import {-# SOURCE #-} Subst( substTyWith )
import Type ( Type, ThetaType,
import Type ( Type, ThetaType, substTyWith,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, splitTyConApp_maybe,
splitTyConApp_maybe,
mkPredTys, isStrictPred, pprType
)
import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon )
import TyCon ( TyCon, FieldLabel, tyConDataCons, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import FieldLabel ( FieldLabel )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual, notNull )
import Util ( zipEqual, zipWithEqual )
\end{code}
......@@ -138,23 +136,34 @@ I say the context is "stupid" because the dictionaries passed
are immediately discarded -- they do nothing and have no benefit.
It's a flaw in the language.
Up to now [March 2002] I have put this stupid context into the type of
the "wrapper" constructors functions, T1 and T2, but that turned out
to be jolly inconvenient for generics, and record update, and other
functions that build values of type T (because they don't have
suitable dictionaries available).
Up to now [March 2002] I have put this stupid context into the
type of the "wrapper" constructors functions, T1 and T2, but
that turned out to be jolly inconvenient for generics, and
record update, and other functions that build values of type T
(because they don't have suitable dictionaries available).
So now I've taken the stupid context out. I simply deal with
it separately in the type checker on occurrences of a
constructor, either in an expression or in a pattern.
So now I've taken the stupid context out. I simply deal with it
separately in the type checker on occurrences of a constructor, either
in an expression or in a pattern.
[May 2003: actually I think this decision could evasily be
reversed now, and probably should be. Generics could be
disabled for types with a stupid context; record updates now
(H98) needs the context too; etc. It's an unforced change, so
I'm leaving it for now --- but it does seem odd that the
wrapper doesn't include the stupid context.]
[May 2003: actually I think this decision could evasily be reversed now,
and probably should be. Generics could be disabled for types with
a stupid context; record updates now (H98) needs the context too; etc.
It's an unforced change, so I'm leaving it for now --- but it does seem
odd that the wrapper doesn't include the stupid context.]
[July 04] With the advent of generalised data types, it's less obvious
what the "stupid context" is. Consider
C :: forall a. Ord a => a -> a -> T (Foo a)
Does the C constructor in Core contain the Ord dictionary? Yes, it must:
f :: T b -> Ordering
f = /\b. \x:T b.
case x of
C a (d:Ord a) (p:a) (q:a) -> compare d p q
Note that (Foo a) might not be an instance of Ord.
%************************************************************************
%* *
......@@ -164,50 +173,41 @@ odd that the wrapper doesn't include the stupid context.]
\begin{code}
data DataCon
= MkData { -- Used for data constructors only;
-- there *is* no constructor for a newtype
= MkData {
dcName :: Name, -- This is the name of the *source data con*
-- (see "Note [Data Constructor Naming]" above)
dcUnique :: Unique, -- Cached from Name
dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag,
-- Running example:
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
dcRepType :: Type, -- Type of the constructor
-- forall a b . Ord b => a -> [b] -> MkT a
-- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
--
-- Notice that the existential type parameters come *second*.
-- Reason: in a case expression we may find:
-- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
-- It's convenient to apply the rep-type of MkT to 't', to get
-- forall b. Ord b => ...
-- and use that to check the pattern. Mind you, this is really only
-- use in CoreLint.
-- The next six fields express the type of the constructor, in pieces
-- e.g.
--
-- dcTyVars = [a]
-- dcTheta = [Eq a]
-- dcExTyVars = [b]
-- dcExTheta = [Ord b]
-- dcOrigArgTys = [a,List b]
-- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars for the data type decl
-- These are ALWAYS THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. We occasionally rely on
-- this just to avoid redundant instantiation
dcStupidTheta :: ThetaType, -- This is a "thinned" version of the context of
-- the data decl.
-- dcTyVars = [a,b]
-- dcStupidTheta = [Eq a]
-- dcTheta = [Ord b]
-- dcOrigArgTys = [a,List b]
-- dcTyCon = T
-- dcTyArgs = [a,b]
dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no GADTs, nothing.
dcTyVars :: [TyVar], -- Universally-quantified type vars
-- for the data constructor.
-- dcVanilla = True <=> The [TyVar] are identical to those of the parent tycon
-- False <=> The [TyVar] are NOT NECESSARILY THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. (With GADTs the data
-- con might not even have the same number of
-- type variables.)
dcStupidTheta :: ThetaType, -- This is a "thinned" version of
-- the context of the data decl.
-- "Thinned", because the Report says
-- to eliminate any constraints that don't mention
-- tyvars free in the arg types for this constructor
......@@ -219,13 +219,16 @@ data DataCon
-- that makes it harder to use the wrap-id to rebuild
-- values after record selection or in generics.
dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
dcExTheta :: ThetaType, -- the existentially quantified stuff
dcTheta :: ThetaType, -- The existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
-- strict fields)
-- Result type of constructor is T t1..tn
dcTyCon :: TyCon, -- Result tycon, T
dcResTys :: [Type], -- Result type args, t1..tn
-- Now the strictness annotations and field labels of the constructor
dcStrictMarks :: [StrictnessMark],
-- Strictness annotations as decided by the compiler.
......@@ -242,16 +245,27 @@ data DataCon
-- after unboxing and flattening,
-- and *including* existential dictionaries
dcRepStrictness :: [StrictnessMark], -- One for each representation argument
dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument
dcRepType :: Type, -- Type of the constructor
-- forall a b . Ord b => a -> [b] -> MkT a
-- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
--
-- Notice that the existential type parameters come *second*.
-- Reason: in a case expression we may find:
-- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
-- It's convenient to apply the rep-type of MkT to 't', to get
-- forall b. Ord b => ...
-- and use that to check the pattern. Mind you, this is really only
-- use in CoreLint.
dcTyCon :: TyCon, -- Result tycon
-- Finally, the curried worker function that corresponds to the constructor
-- It doesn't have an unfolding; the code generator saturates these Ids
-- and allocates a real constructor when it finds one.
--
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
dcInfix :: Bool -- True <=> declared infix
......@@ -347,29 +361,28 @@ instance Show DataCon where
\begin{code}
mkDataCon :: Name
-> Bool -- Declared infix
-> Bool -- Vanilla (see notes with dcVanilla)
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
-> [Type] -> TyCon
-> [TyVar] -> ThetaType -> ThetaType
-> [Type] -> TyCon -> [Type]
-> DataConIds
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name declared_infix
mkDataCon name declared_infix vanilla
arg_stricts -- Must match orig_arg_tys 1-1
fields
tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
tyvars stupid_theta theta orig_arg_tys tycon res_tys
ids
= con
where
con = MkData {dcName = name,
dcUnique = nameUnique name,
dcTyVars = tyvars, dcStupidTheta = theta,
dcOrigArgTys = orig_arg_tys,
dcUnique = nameUnique name, dcVanilla = vanilla,
dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta,
dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys,
dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids, dcInfix = declared_infix}
-- Strictness marks for source-args
......@@ -379,19 +392,18 @@ mkDataCon name declared_infix
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
ex_dict_tys = mkPredTys ex_theta
real_arg_tys = ex_dict_tys ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark ex_theta ++ arg_stricts
dict_tys = mkPredTys theta
real_arg_tys = dict_tys ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
-- Representation arguments and demands
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys (tyvars ++ ex_tyvars)
(mkFunTys rep_arg_tys result_ty)
ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
result_ty = mkTyConApp tycon res_tys
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
......@@ -413,6 +425,9 @@ dataConRepType = dcRepType
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
dataConTyVars :: DataCon -> [TyVar]
dataConTyVars = dcTyVars
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
AlgDC _ wrk_id -> wrk_id
......@@ -445,12 +460,7 @@ dataConStrictMarks = dcStrictMarks
dataConExStricts :: DataCon -> [StrictnessMark]
-- Strictness of *existential* arguments only
-- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_dict_strict_mark (dcExTheta dc)
-- Number of type-instantiation arguments
-- All the remaining arguments of the DataCon are (notionally)
-- stored in the DataCon, and are matched in a case expression
dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars
dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc)
dataConSourceArity :: DataCon -> Arity
-- Source-level arity of the data constructor
......@@ -462,7 +472,9 @@ dataConSourceArity dc = length (dcOrigArgTys dc)
-- dictionaries
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
isNullaryDataCon con = dataConRepArity con == 0
isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
isNullaryRepDataCon dc = null (dcRepArgTys dc)
dataConRepStrictness :: DataCon -> [StrictnessMark]
-- Give the demands on the arguments of a
......@@ -470,13 +482,11 @@ dataConRepStrictness :: DataCon -> [StrictnessMark]
dataConRepStrictness dc = dcRepStrictness dc
dataConSig :: DataCon -> ([TyVar], ThetaType,
[TyVar], ThetaType,
[Type], TyCon)
[Type], TyCon, [Type])
dataConSig (MkData {dcTyVars = tyvars, dcStupidTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys})
= (tyvars, theta, arg_tys, tycon, res_tys)
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
......@@ -485,23 +495,18 @@ dataConArgTys :: DataCon
-- NB: these INCLUDE the existentially quantified dict args
-- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
= map (substTyWith tyvars inst_tys) arg_tys
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
= map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcStupidTheta dc
dataConExistentialTyVars :: DataCon -> [TyVar]
dataConExistentialTyVars dc = dcExTyVars dc
-- And the same deal for the original arg tys:
-- And the same deal for the original arg tys
-- This one only works for vanilla DataCons
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
= map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, dcVanilla = is_vanilla}) inst_tys
= ASSERT( is_vanilla )
map (substTyWith tyvars inst_tys) arg_tys
dataConStupidTheta :: DataCon -> ThetaType
dataConStupidTheta dc = dcStupidTheta dc
\end{code}
These two functions get the real argument types of the constructor,
......@@ -528,8 +533,8 @@ isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc
isUnboxedTupleCon :: DataCon -> Bool
isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
isExistentialDataCon :: DataCon -> Bool
isExistentialDataCon (MkData {dcExTyVars = tvs}) = notNull tvs
isVanillaDataCon :: DataCon -> Bool
isVanillaDataCon dc = dcVanilla dc
\end{code}
......
......@@ -90,6 +90,7 @@ import Var ( Id, DictId,
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
import TyCon ( FieldLabel, TyCon )
import Type ( Type, typePrimRep, addFreeTyVars, seqType,
splitTyConApp_maybe, PrimRep )
import TysPrim ( statePrimTyCon )
......@@ -106,7 +107,6 @@ import Name ( Name, OccName, nameIsLocalOrFrom,
)
import Module ( Module )
import OccName ( EncodedFS, mkWorkerOcc )
import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
......@@ -239,13 +239,13 @@ Meanwhile, it is not discarded as dead code.
\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of
RecordSelId lbl -> lbl
RecordSelId tycon lbl -> (tycon,lbl)
other -> panic "recordSelectorFieldLabel"
isRecordSelector id = case globalIdDetails id of
RecordSelId lbl -> True
RecordSelId _ _ -> True
other -> False
isPrimOpId id = case globalIdDetails id of
......@@ -290,7 +290,7 @@ isImplicitId :: Id -> Bool
-- file, even if it's mentioned in some other interface unfolding.
isImplicitId id
= case globalIdDetails id of
RecordSelId _ -> True
RecordSelId _ _ -> True
FCallId _ -> True
PrimOpId _ -> True
ClassOpId _ -> True
......
......@@ -87,8 +87,8 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea
Activation(..)
)
import DataCon ( DataCon )
import TyCon ( TyCon, FieldLabel )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import NewDemand
import Outputable
import Maybe ( isJust )
......@@ -230,7 +230,8 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported
data GlobalIdDetails
= VanillaGlobal -- Imported from elsewhere, a default method Id.
| RecordSelId FieldLabel -- The Id for a record selector
| RecordSelId TyCon FieldLabel -- The Id for a record selector
| DataConWorkId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
-- [the only reasons we need to know is so that
......@@ -255,7 +256,7 @@ instance Outputable GlobalIdDetails where
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
ppr (RecordSelId _) = ptext SLIT("[RecSel]")
ppr (RecordSelId _ _) = ptext SLIT("[RecSel]")
\end{code}
......
......@@ -7,7 +7,7 @@
module Literal
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
, mkMachInt64, mkMachWord64, mkStringLit,
, litSize
, litIsDupable, litIsTrivial
, literalType,
......@@ -35,6 +35,7 @@ import FastTypes
import FastString
import Binary
import UnicodeUtil ( stringToUtf8 )
import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS )
import DATA_INT ( Int8, Int16, Int32 )
......@@ -204,6 +205,9 @@ mkMachWord x = -- ASSERT2( inWordRange x, integer x )
mkMachInt64 x = MachInt64 x
mkMachWord64 x = MachWord64 x
mkStringLit :: String -> Literal
mkStringLit s = MachStr (mkFastString (stringToUtf8 s))
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
......
......@@ -52,22 +52,22 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
)
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..), nullAddrLit )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classTyVars, classSelIds )
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
import OccName ( mkOccFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..),
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
dataConFieldLabels, dataConRepArity,
dataConArgTys, dataConRepType,
dataConOrigArgTys, dataConTheta,
dataConRepArgTys, dataConRepType,
dataConStupidTheta, dataConOrigArgTys,
dataConSig, dataConStrictMarks, dataConExStricts,
splitProductType
splitProductType, isVanillaDataCon
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
......@@ -81,9 +81,6 @@ import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
import NewDemand ( mkStrictSig, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
Demand(..), Demands(..) )
import FieldLabel ( fieldLabelName, firstFieldLabelTag,
allFieldLabelTags, fieldLabelType
)
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
......@@ -94,7 +91,6 @@ import Util ( dropList, isSingleton )
import Outputable
import FastString
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
\end{code}
......@@ -200,14 +196,13 @@ mkDataConIds wrap_name wkr_name data_con
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
(tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
all_tyvars = tyvars ++ ex_tyvars
(tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
ex_dict_tys = mkPredTys ex_theta
all_arg_tys = ex_dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
dict_tys = mkPredTys theta
all_arg_tys = dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon res_tys
wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
-- We used to include the stupid theta in the wrapper's args
-- but now we don't. Instead the type checker just injects these
-- extra constraints where necessary.
......@@ -251,8 +246,8 @@ mkDataConIds wrap_name wkr_name data_con
nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
newtype_unf = ASSERT( null ex_tyvars && null ex_theta &&
isSingleton orig_arg_tys )
newtype_unf = ASSERT( isVanillaDataCon data_con &&
isSingleton orig_arg_tys )
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkTopUnfolding $ Note InlineMe $
......@@ -285,18 +280,18 @@ mkDataConIds wrap_name wkr_name data_con
-- we want to see that w is strict in its two arguments
alg_unf = mkTopUnfolding $ Note InlineMe $
mkLams all_tyvars $
mkLams ex_dict_args $ mkLams id_args $
mkLams tyvars $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (ex_dict_args ++ id_args) all_strict_marks)
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
con_app i rep_ids = mkApps (Var wrk_id)
(map varToCoreExpr (all_tyvars ++ reverse rep_ids))
(map varToCoreExpr (tyvars ++ reverse rep_ids))