Commit d5bba9ee authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Massive patch for the first months work adding System FC to GHC #1

Fri Aug  4 15:11:01 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Massive patch for the first months work adding System FC to GHC #1
  Broken up massive patch -=chak
  Original log message:  
  This is (sadly) all done in one patch to avoid Darcs bugs.
  It's not complete work... more FC stuff to come.  A compiler
  using just this patch will fail dismally.
parent 07f3c0c8
......@@ -31,6 +31,8 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
OverlapFlag(..),
Boxity(..), isBoxed,
TupCon(..), tupleParens,
......@@ -217,7 +219,7 @@ instance Outputable TopLevelFlag where
%************************************************************************
%* *
\subsection[Top-level/local]{Top-level/not-top level flag}
Top-level/not-top level flag
%* *
%************************************************************************
......@@ -235,7 +237,7 @@ isBoxed Unboxed = False
%************************************************************************
%* *
\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag}
Recursive/Non-Recursive flag
%* *
%************************************************************************
......@@ -261,6 +263,46 @@ instance Outputable RecFlag where
ppr NonRecursive = ptext SLIT("NonRecursive")
\end{code}
%************************************************************************
%* *
Instance overlap flag
%* *
%************************************************************************
\begin{code}
data OverlapFlag
= NoOverlap -- This instance must not overlap another
| OverlapOk -- Silently ignore this instance if you find a
-- more specific one that matches the constraint
-- you are trying to resolve
--
-- Example: constraint (Foo [Int])
-- instances (Foo [Int])
-- (Foo [a]) OverlapOk
-- Since the second instance has the OverlapOk flag,
-- the first instance will be chosen (otherwise
-- its ambiguous which to choose)
| Incoherent -- Like OverlapOk, but also ignore this instance
-- if it doesn't match the constraint you are
-- trying to resolve, but could match if the type variables
-- in the constraint were instantiated
--
-- Example: constraint (Foo [b])
-- instances (Foo [Int]) Incoherent
-- (Foo [a])
-- Without the Incoherent flag, we'd complain that
-- instantiating 'b' would change which instance
-- was chosen
instance Outputable OverlapFlag where
ppr NoOverlap = empty
ppr OverlapOk = ptext SLIT("[overlap ok]")
ppr Incoherent = ptext SLIT("[incoherent]")
\end{code}
%************************************************************************
%* *
Tuples
......
......@@ -8,10 +8,11 @@ module DataCon (
DataCon, DataConIds(..),
ConTag, fIRST_TAG,
mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
dataConTyVars, dataConResTys,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConInstResTy,
dataConRepType, dataConSig, dataConFullSig,
dataConName, dataConTag, dataConTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
dataConEqSpec, dataConTheta, dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
......@@ -27,21 +28,25 @@ module DataCon (
#include "HsVersions.h"
import Type ( Type, ThetaType, substTyWith, substTy, zipOpenTvSubst,
mkForAllTys, mkFunTys, mkTyConApp,
import Type ( Type, ThetaType,
substTyWith, substTyVar, mkTopTvSubst,
mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
splitTyConApp_maybe,
mkPredTys, isStrictPred, pprType
)
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon )
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
isNewTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import ListSetOps ( assoc )
import ListSetOps ( assoc, minusList )
import Util ( zipEqual, zipWithEqual )
import List ( partition )
import Maybes ( expectJust )
\end{code}
......@@ -184,68 +189,77 @@ data DataCon
-- Running example:
--
-- data Eq a => T a = forall b. Ord b => MkT a [b]
-- *** As declared by the user
-- data T a where
-- MkT :: forall x y. (Ord x) => x -> y -> T (x,y)
-- *** As represented internally
-- data T a where
-- MkT :: forall a. forall x y. (a:=:(x,y), Ord x) => x -> y -> T a
--
-- The next six fields express the type of the constructor, in pieces
-- e.g.
--
-- dcTyVars = [a,b]
-- dcStupidTheta = [Eq a]
-- dcTheta = [Ord b]
-- dcUnivTyVars = [a]
-- dcExTyVars = [x,y]
-- dcEqSpec = [a:=:(x,y)]
-- dcTheta = [Ord x]
-- 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.
--
-- NB1: the order of the forall'd variables does matter;
-- for a vanilla constructor, we assume that if the result
-- type is (T t1 ... tn) then we can instantiate the constr
-- at types [t1, ..., tn]
--
-- NB2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
dcTyVars :: [TyVar], -- Universally-quantified type vars
-- for the data constructor.
-- See NB1 on dcVanilla for the conneciton between dcTyVars and dcResTys
--
-- In general, the dcTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
-- No existentials, no coercions, nothing.
-- That is: dcExTyVars = dcEqSpec = dcTheta = []
-- NB 1: newtypes always have a vanilla data con
-- NB 2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
-- The declaration format is held in the TyCon (algTcGadtSyntax)
dcUnivTyVars :: [TyVar], -- Universally-quantified type vars
dcExTyVars :: [TyVar], -- Existentially-quantified type vars
-- In general, the dcUnivTyVars 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.
-- [This is a change (Oct05): previously, vanilla datacons guaranteed to
-- have the same type variables as their parent TyCon, but that seems ugly.]
dcStupidTheta :: ThetaType, -- This is a "thinned" version of
-- the context of the data decl.
dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type,
-- *as written by the programmer*
-- This field allows us to move conveniently between the two ways
-- of representing a GADT constructor's type:
-- MkT :: forall a b. (a :=: [b]) => b -> T a
-- MkT :: forall b. b -> T [b]
-- Each equality is of the form (a :=: ty), where 'a' is one of
-- the universally quantified type variables
dcTheta :: ThetaType, -- The context of the constructor
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a. Eq a => a -> T a
-- It may contain user-written equality predicates too
dcStupidTheta :: ThetaType, -- The context of the data type declaration
-- data Eq a => T a = ...
-- or, rather, a "thinned" version thereof
-- "Thinned", because the Report says
-- to eliminate any constraints that don't mention
-- tyvars free in the arg types for this constructor
--
-- "Stupid", because the dictionaries aren't used for anything.
-- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars
-- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon
--
-- Indeed, [as of March 02] they are no
-- longer in the type of the wrapper Id, because
-- that makes it harder to use the wrap-id to rebuild
-- values after record selection or in generics.
--
-- Fact: the free tyvars of dcStupidTheta are a subset of
-- the free tyvars of dcResTys
-- Reason: dcStupidTeta is gotten by instantiating the
-- stupid theta from the tycon (see BuildTyCl.mkDataConStupidTheta)
-- "Stupid", because the dictionaries aren't used for anything.
-- Indeed, [as of March 02] they are no longer in the type of
-- the wrapper Id, because that makes it harder to use the wrap-id
-- to rebuild values after record selection or in generics.
dcTheta :: ThetaType, -- The existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
-- strict fields)
-- (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],
......@@ -266,10 +280,9 @@ data DataCon
dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument
dcRepType :: Type, -- Type of the constructor
-- forall a b . Ord b => a -> [b] -> MkT a
-- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a
-- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
--
-- see Note [Data con representation] below)
-- 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]) -> ... }
......@@ -321,6 +334,8 @@ fIRST_TAG :: ConTag
fIRST_TAG = 1 -- Tags allocated from here for real constructors
\end{code}
Note [Data con representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a contructor
This may differ from the type of the contructor *Id* (built
by MkId.mkDataConId) for two reasons:
......@@ -379,29 +394,36 @@ instance Show DataCon where
\begin{code}
mkDataCon :: Name
-> Bool -- Declared infix
-> Bool -- Vanilla (see notes with dcVanilla)
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType -> ThetaType
-> [Type] -> TyCon -> [Type]
-> DataConIds
-> [TyVar] -> [TyVar]
-> [(TyVar,Type)] -> ThetaType
-> [Type] -> TyCon
-> ThetaType -> DataConIds
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name declared_infix vanilla
mkDataCon name declared_infix
arg_stricts -- Must match orig_arg_tys 1-1
fields
tyvars stupid_theta theta orig_arg_tys tycon res_tys
ids
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys tycon
stupid_theta ids
= con
where
con = MkData {dcName = name,
dcUnique = nameUnique name, dcVanilla = vanilla,
dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta,
dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys,
is_vanilla = null ex_tvs && null eq_spec && null theta
con = ASSERT( is_vanilla || not (isNewTyCon tycon) )
-- Invariant: newtypes have a vanilla data-con
MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
dcStupidTheta = stupid_theta, dcTheta = theta,
dcOrigArgTys = orig_arg_tys, dcTyCon = tycon,
dcRepArgTys = rep_arg_tys,
dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids, dcInfix = declared_infix}
dcIds = ids }
-- Strictness marks for source-args
-- *after unboxing choices*,
......@@ -410,18 +432,26 @@ mkDataCon name declared_infix vanilla
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
(more_eq_preds, dict_preds) = partition isEqPred theta
dict_tys = mkPredTys theta
real_arg_tys = dict_tys ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
real_stricts = map mk_dict_strict_mark dict_preds ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
-- NB: the dict args are already in rep_arg_tys
-- because they might be flattened..
-- but the equality predicates are not
mkFunTys rep_arg_tys $
mkTyConApp tycon (mkTyVarTys univ_tvs)
result_ty = mkTyConApp tycon res_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
......@@ -443,8 +473,21 @@ dataConRepType = dcRepType
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
dataConTyVars :: DataCon -> [TyVar]
dataConTyVars = dcTyVars
dataConUnivTyVars :: DataCon -> [TyVar]
dataConUnivTyVars = dcUnivTyVars
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dcExTyVars
dataConAllTyVars :: DataCon -> [TyVar]
dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
= univ_tvs ++ ex_tvs
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
dataConTheta :: DataCon -> ThetaType
dataConTheta = dcTheta
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
......@@ -505,18 +548,41 @@ dataConRepStrictness :: DataCon -> [StrictnessMark]
-- Core constructor application (Con dc args)
dataConRepStrictness dc = dcRepStrictness dc
dataConSig :: DataCon -> ([TyVar], ThetaType,
[Type], TyCon, [Type])
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type])
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys})
= (tyvars, theta, arg_tys, tycon, res_tys)
dataConFullSig :: DataCon
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type])
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (univ_tvs, ex_tvs, eq_spec, theta, arg_tys)
dataConStupidTheta :: DataCon -> ThetaType
dataConStupidTheta dc = dcStupidTheta dc
dataConResTys :: DataCon -> [Type]
dataConResTys dc = dcResTys dc
dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc]
where
env = mkTopTvSubst (dcEqSpec dc)
dataConUserType :: DataCon -> Type
-- The user-declared type of the data constructor
-- in the nice-to-read form
-- T :: forall a. a -> T [a]
-- rather than
-- T :: forall b. forall a. (a=[b]) => a -> T b
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcTheta = theta, dcOrigArgTys = arg_tys,
dcTyCon = tycon })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
mkTyConApp tycon (map (substTyVar subst) univ_tvs)
where
subst = mkTopTvSubst eq_spec
dataConInstArgTys :: DataCon
-> [Type] -- Instantiated at these types
......@@ -525,22 +591,23 @@ dataConInstArgTys :: 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
dataConInstArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
dataConInstArgTys (MkData {dcRepArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
dataConInstResTy :: DataCon -> [Type] -> Type
dataConInstResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys
= ASSERT( length tyvars == length inst_tys )
substTy (zipOpenTvSubst tyvars inst_tys) (mkTyConApp tc res_tys)
-- res_tys can't currently contain any foralls,
-- but might in future; hence zipOpenTvSubst
where
tyvars = univ_tvs ++ ex_tvs
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
\end{code}
These two functions get the real argument types of the constructor,
......
......@@ -525,8 +525,8 @@ clearOneShotLambda id
\begin{code}
zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
zapLamIdInfo id = maybeModifyIdInfo (zapLamInfo (idInfo id)) id
zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
zapDemandIdInfo id = maybeModifyIdInfo (zapDemandInfo (idInfo id)) id
\end{code}
......@@ -20,7 +20,7 @@ module MkId (
mkRecordSelId,
mkPrimOpId, mkFCallId,
mkReboxingAlt, mkNewTypeBody,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
......@@ -46,6 +46,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
import Coercion ( mkSymCoercion, mkUnsafeCoercion )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
......@@ -56,7 +57,8 @@ import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
newTyConCo, tyConArity )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
......@@ -64,7 +66,7 @@ import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType,
dataConSig, dataConStrictMarks, dataConExStricts,
......@@ -184,8 +186,6 @@ Notice that
\begin{code}
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
-- Makes the *worker* for the data constructor; that is, the function
-- that takes the reprsentation arguments and builds the constructor.
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
= NewDC nt_wrap_id
......@@ -196,18 +196,23 @@ mkDataConIds wrap_name wkr_name data_con
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
(tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
(tvs, theta, orig_arg_tys) = dataConSig data_con
tycon = dataConTyCon data_con
dict_tys = mkPredTys theta
all_arg_tys = dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon res_tys
tycon_args = dataConUnivTyVars data_con
result_ty_args = (mkTyVarTys tycon_args)
result_ty = mkTyConApp tycon result_ty_args
wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
wrap_ty = mkForAllTys tvs (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.
----------- Worker (algebraic data types only) --------------
-- The *worker* for the data constructor is the function that
-- takes the representation arguments and builds the constructor.
wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
(dataConRepType data_con) wkr_info
......@@ -253,8 +258,9 @@ mkDataConIds wrap_name wkr_name data_con
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkCompulsoryUnfolding $
mkLams tyvars $ Lam id_arg1 $
mkNewTypeBody tycon result_ty (Var id_arg1)
mkLams tvs $ Lam id_arg1 $
wrapNewTypeBody tycon result_ty_args
(Var id_arg1)
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
......@@ -282,14 +288,14 @@ 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 tyvars $
mkLams tvs $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
con_app i rep_ids = mkApps (Var wrk_id)
(map varToCoreExpr (tyvars ++ reverse rep_ids))
(map varToCoreExpr (tvs ++ reverse rep_ids))
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
......@@ -391,11 +397,13 @@ We obviously can't define
Nevertheless we *do* put a RecordSelId into the type environment
so that if the user tries to use 'x' as a selector we can bleat
helpfully, rather than saying unhelpfully that 'x' is not in scope.
Hence the sel_naughty flag, to identify record selcectors that don't really exist.
Hence the sel_naughty flag, to identify record selectors that don't really exist.
In general, a field is naughty if its type mentions a type variable that
isn't in the result type of the constructor.
Note [GADT record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For GADTs, we require that all constructors with a common field 'f' have the same
result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
E.g.
......@@ -424,7 +432,7 @@ mkRecordSelId tycon field_label
| is_naughty = naughty_id
| otherwise = sel_id
where
is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
is_naughty = not (tyVarsOfType field_ty `subVarSet` res_tv_set)
sel_id_details = RecordSelId tycon field_label is_naughty
-- Escapist case here for naughty construcotrs
......@@ -440,8 +448,8 @@ mkRecordSelId tycon field_label
con1 = head data_cons_w_field
res_tys = dataConResTys con1
tyvar_set = tyVarsOfTypes res_tys
tyvars = varSetElems tyvar_set
res_tv_set = tyVarsOfTypes res_tys
res_tvs = varSetElems res_tv_set
data_ty = mkTyConApp tycon res_tys
field_ty = dataConFieldType con1 field_label
......@@ -475,7 +483,7 @@ mkRecordSelId tycon field_label
-- op (R op) = op
selector_ty :: Type
selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
selector_ty = mkForAllTys res_tvs $ mkForAllTys field_tyvars $
mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
mkFunTy data_ty field_tau
......@@ -515,11 +523,13 @@ mkRecordSelId tycon field_label
caf_info | no_default = NoCafRefs
| otherwise = MayHaveCafRefs
sel_rhs = mkLams tyvars $ mkLams field_tyvars $
sel_rhs = mkLams res_tvs $ mkLams field_tyvars $
mkLams stupid_dict_ids $ mkLams field_dict_ids $
Lam data_id $ sel_body
Lam data_id $ mk_result sel_body
sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
-- NB: A newtype always has a vanilla DataCon; no existentials etc
-- res_tys will simply be the dataConUnivTyVars
sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id)
| otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
......@@ -533,18 +543,17 @@ mkRecordSelId tycon field_label
mk_alt data_con
= -- In the non-vanilla case, the pattern must bind type variables and
-- the context stuff; hence the arg_prefix binding below
mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
(mk_result (Var the_arg_id))
mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
where
(arg_prefix, arg_ids)
| isVanillaDataCon data_con -- Instantiate from commmon base
= ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
| otherwise -- The case pattern binds type variables, which are used
-- in the types of the arguments of the pattern
= (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
= (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
mkTemplateLocalsNum arg_base' dc_arg_tys)
(dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
(dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con
arg_base' = arg_base + length dc_theta
unpack_base = arg_base' + length dc_arg_tys
......@@ -602,12 +611,17 @@ mkReboxingAlt us con args rhs
go (arg:args) (str:stricts) us
| isMarkedUnboxed str
= let
(_, tycon_args, pack_con, con_arg_tys)
= splitProductType "mkReboxingAlt" (idType arg)
ty = idType arg
(tycon, tycon_args, pack_con, con_arg_tys)
= splitProductType "mkReboxingAlt" ty
unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
(binds, args') = go args stricts (dropList con_arg_tys us)
con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args )
wrapNewTypeBody tycon tycon_args (Var (head unpacked_args))
-- ToDo: is this right? Jun06
| otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
(NonRec arg con_app : binds, unpacked_args ++ args')
......@@ -672,26 +686,58 @@ mkDictSelId name clas
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
tyvars = dataConTyVars data_con
arg_tys = dataConRepArgTys data_con
tyvars = dataConUnivTyVars data_con
arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con
the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
pred = mkClassPred clas (mkTyVarTys tyvars)
(dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
mkNewTypeBody tycon (head arg_tys) (Var dict_id)
| otherwise = mkLams tyvars $ Lam dict_id $
Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, arg_ids, Var the_arg_id)]
mkNewTypeBody tycon result_ty result_expr
-- Adds a coerce where necessary
-- Used for both wrapping and unwrapping
| isRecursiveTyCon tycon -- Recursive case; use a coerce
= Note (Coerce result_ty (exprType result_expr)) result_expr
| otherwise -- Normal case
= result_expr
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, arg_ids, Var the_arg_id)]
wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- The wrapper for the data constructor for a newtype looks like this: