Commit d069cec2 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-06-25 08:09:57 by simonpj]

----------------
	Squash newtypes
	----------------

This commit squashes newtypes and their coerces, from the typechecker
onwards.  The original idea was that the coerces would not get in the
way of optimising transformations, but despite much effort they continue
to do so.   There's no very good reason to retain newtype information
beyond the typechecker, so now we don't.

Main points:

* The post-typechecker suite of Type-manipulating functions is in
types/Type.lhs, as before.   But now there's a new suite in types/TcType.lhs.
The difference is that in the former, newtype are transparent, while in
the latter they are opaque.  The typechecker should only import TcType,
not Type.

* The operations in TcType are all non-monadic, and most of them start with
"tc" (e.g. tcSplitTyConApp).  All the monadic operations (used exclusively
by the typechecker) are in a new module, typecheck/TcMType.lhs

* I've grouped newtypes with predicate types, thus:
	data Type = TyVarTy Tyvar | ....
		  | SourceTy SourceType

	data SourceType = NType TyCon [Type]
			| ClassP Class [Type]
			| IParam Type

[SourceType was called PredType.]  This is a little wierd in some ways,
because NTypes can't occur in qualified types.   However, the idea is that
a SourceType is a type that is opaque to the type checker, but transparent
to the rest of the compiler, and newtypes fit that as do implicit parameters
and dictionaries.

* Recursive newtypes still retain their coreces, exactly as before. If
they were transparent we'd get a recursive type, and that would make
various bits of the compiler diverge (e.g. things which do type comparison).

* I've removed types/Unify.lhs (non-monadic type unifier and matcher),
merging it into TcType.

Ditto typecheck/TcUnify.lhs (monadic unifier), merging it into TcMType.
parent 3622a7de
......@@ -25,12 +25,12 @@ module DataCon (
import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
import CmdLineOpts ( opt_DictsStrict )
import Type ( Type, TauType, ThetaType,
import Type ( Type, TauType, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, mkPredTys, getClassPredTys_maybe,
splitTyConApp_maybe, repType
mkTyVarTys, splitTyConApp_maybe, repType
)
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
import TcType ( isStrictPred, mkPredTys )
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
......@@ -254,11 +254,8 @@ mkDataCon name arg_stricts fields
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
mk_dict_strict_mark pred
| opt_DictsStrict, -- Don't mark newtype things as strict!
Just (clas,_) <- getClassPredTys_maybe pred,
isDataTyCon (classTyCon clas) = MarkedStrict
| otherwise = NotMarkedStrict
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
\end{code}
\begin{code}
......
......@@ -7,7 +7,7 @@
module Demand(
Demand(..),
wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum,
wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
isStrict, isLazy, isPrim,
pprDemands, seqDemand, seqDemands,
......@@ -23,7 +23,6 @@ module Demand(
#include "HsVersions.h"
import BasicTypes ( NewOrData(..) )
import Outputable
\end{code}
......@@ -47,7 +46,6 @@ data Demand
-- calling-convention magic)
| WwUnpack -- Argument is strict & a single-constructor type
NewOrData
Bool -- True <=> wrapper unpacks it; False <=> doesn't
[Demand] -- Its constituent parts (whose StrictInfos
-- are in the list) should be passed
......@@ -67,16 +65,14 @@ type MaybeAbsent = Bool -- True <=> not even used
-- versions that don't worry about Absence:
wwLazy = WwLazy False
wwStrict = WwStrict
wwUnpackData xs = WwUnpack DataType False xs
wwUnpackNew x = ASSERT( isStrict x) -- Invariant
WwUnpack NewType False [x]
wwUnpack xs = WwUnpack False xs
wwPrim = WwPrim
wwEnum = WwEnum
seqDemand :: Demand -> ()
seqDemand (WwLazy a) = a `seq` ()
seqDemand (WwUnpack nd b ds) = nd `seq` b `seq` seqDemands ds
seqDemand other = ()
seqDemand (WwLazy a) = a `seq` ()
seqDemand (WwUnpack b ds) = b `seq` seqDemands ds
seqDemand other = ()
seqDemands [] = ()
seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
......@@ -91,8 +87,6 @@ seqDemands (d:ds) = seqDemand d `seq` seqDemands ds
\begin{code}
isLazy :: Demand -> Bool
-- Even a demand of (WwUnpack NewType _ _) is strict
-- We don't create such a thing unless the demand inside is strict
isLazy (WwLazy _) = True
isLazy _ = False
......@@ -124,13 +118,9 @@ pprDemand (WwLazy True) = char 'A'
pprDemand WwStrict = char 'S'
pprDemand WwPrim = char 'P'
pprDemand WwEnum = char 'E'
pprDemand (WwUnpack nd wu args) = char ch <> parens (hcat (map pprDemand args))
pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args))
where
ch = case nd of
DataType | wu -> 'U'
| otherwise -> 'u'
NewType | wu -> 'N'
| otherwise -> 'n'
ch = if wu then 'U' else 'u'
instance Outputable Demand where
ppr (WwLazy False) = empty
......
......@@ -84,7 +84,7 @@ import Var ( Id, DictId,
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
usOnce, seqType, splitTyConApp_maybe )
usOnce, eqUsage, seqType, splitTyConApp_maybe )
import IdInfo
......@@ -431,7 +431,7 @@ idLBVarInfo id = lbvarInfo (idInfo id)
isOneShotLambda :: Id -> Bool
isOneShotLambda id = analysis || hack
where analysis = case idLBVarInfo id of
LBVarInfo u | u == usOnce -> True
LBVarInfo u | u `eqUsage` usOnce -> True
other -> False
hack = case splitTyConApp_maybe (idType id) of
Just (tycon,_) | tycon == statePrimTyCon -> True
......
......@@ -77,7 +77,7 @@ module IdInfo (
import CoreSyn
import Type ( Type, usOnce )
import Type ( Type, usOnce, eqUsage )
import PrimOp ( PrimOp )
import NameEnv ( NameEnv, lookupNameEnv )
import Name ( Name )
......@@ -395,8 +395,6 @@ data TyGenInfo
-- preserve specified usage annotations
| TyGenNever -- never generalise the type of this Id
deriving ( Eq )
\end{code}
For TyGenUInfo, the list has one entry for each usage annotation on
......@@ -428,9 +426,9 @@ ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us)
ppTyGenInfo TyGenNever = ptext SLIT("__G N")
tyGenInfoString us = map go us
where go Nothing = 'x' -- for legibility, choose
go (Just u) | u == usOnce = '1' -- chars with identity
| u == usMany = 'M' -- Z-encoding.
where go Nothing = 'x' -- for legibility, choose
go (Just u) | u `eqUsage` usOnce = '1' -- chars with identity
| u `eqUsage` usMany = 'M' -- Z-encoding.
go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other)
instance Outputable TyGenInfo where
......@@ -670,7 +668,7 @@ noLBVarInfo = NoLBVarInfo
-- not safe to print or parse LBVarInfo because it is not really a
-- property of the definition, but a property of the context.
pprLBVarInfo NoLBVarInfo = empty
pprLBVarInfo (LBVarInfo u) | u == usOnce
pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce
= getPprStyle $ \ sty ->
if ifaceStyle sty
then empty
......
......@@ -28,7 +28,8 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
)
import PrimRep ( PrimRep(..) )
import Type ( Type, typePrimRep )
import TcType ( Type, tcCmpType )
import Type ( typePrimRep )
import PprType ( pprParendType )
import CStrings ( pprFSInCStyle )
......@@ -268,7 +269,7 @@ cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a) (MachLabel b) = a `compare` b
cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d)
cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
......
......@@ -39,18 +39,18 @@ import TysWiredIn ( charTy, mkListTy )
import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
import Type ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
mkTyVarTys, repType, isNewType,
mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy,
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
mkTyVarTys, mkClassPred, tcEqPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
splitFunTys, splitForAllTys, mkPredTy
tcSplitFunTys, tcSplitForAllTys, mkPredTy
)
import Module ( Module )
import CoreUtils ( exprType, mkInlineMe )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..) )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
tyConTheta, isProductTyCon, isDataTyCon )
tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
......@@ -70,7 +70,7 @@ import DataCon ( DataCon,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idCprInfo
mkTemplateLocal, idCprInfo, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
exactArity, setUnfoldingInfo, setCprInfo,
......@@ -157,7 +157,7 @@ mkDataConId work_name data_con
arity <= mAX_CPR_SIZE = ReturnsCPR
| otherwise = NoCPRInfo
-- ReturnsCPR is only true for products that are real data types;
-- that is, not unboxed tuples or newtypes
-- that is, not unboxed tuples or [non-recursive] newtypes
mAX_CPR_SIZE :: Arity
mAX_CPR_SIZE = 10
......@@ -236,9 +236,8 @@ mkDataConWrapId data_con
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
mkNewTypeBody tycon result_ty id_arg1
| null dict_args && not (any isMarkedStrict strict_marks)
= Var work_id -- The common case. Not only is this efficient,
......@@ -303,24 +302,12 @@ mkDataConWrapId data_con
Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
| isNewType arg_ty ->
Let (NonRec coerced_arg
(Note (Coerce rep_ty arg_ty) (Var arg)))
(do_unbox coerced_arg rep_ty i')
| otherwise ->
do_unbox arg arg_ty i
where
([coerced_arg],i') = mkLocals i [rep_ty]
arg_ty = idType arg
rep_ty = repType arg_ty
do_unbox arg ty i =
case splitProductType "do_unbox" ty of
-> case splitProductType "do_unbox" (idType arg) of
(tycon, tycon_args, con, tys) ->
Case (Var arg) arg [(DataAlt con, con_args,
body i' (reverse con_args ++ rep_args))]
where
(con_args, i') = mkLocals i tys
(con_args, i') = mkLocals i tys
\end{code}
......@@ -388,11 +375,11 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
-- eg data (Eq a, Ord b) => T a b = ...
dict_tys = [mkPredTy pred | pred <- tycon_theta,
needed_dict pred]
needed_dict pred = or [ pred `elem` (dataConTheta dc)
| (DataAlt dc, _, _) <- the_alts]
needed_dict pred = or [ tcEqPred pred p
| (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc]
n_dict_tys = length dict_tys
(field_tyvars,field_theta,field_tau) = splitSigmaTy field_ty
(field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
field_dict_tys = map mkPredTy field_theta
n_field_dict_tys = length field_dict_tys
-- If the field has a universally quantified type we have to
......@@ -457,8 +444,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
mkLams dict_ids $ mkLams field_dict_ids $
Lam data_id $ sel_body
sel_body | isNewTyCon tycon = Note (Coerce field_tau data_ty) (Var data_id)
| otherwise = Case (Var data_id) data_id (the_alts ++ default_alt)
sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau data_id
| otherwise = Case (Var data_id) data_id (default_alt ++ the_alts)
mk_maybe_alt data_con
= case maybe_the_arg_id of
......@@ -519,24 +506,15 @@ rebuildConArgs (arg:args) (str:stricts) us
| isMarkedUnboxed str
= let
arg_ty = idType arg
prod_ty | isNewType arg_ty = repType arg_ty
| otherwise = arg_ty
(_, tycon_args, pack_con, con_arg_tys)
= splitProductType "rebuildConArgs" prod_ty
= splitProductType "rebuildConArgs" arg_ty
unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
(binds, args') = rebuildConArgs args stricts
(drop (length con_arg_tys) us)
coerce | isNewType arg_ty = Note (Coerce arg_ty prod_ty) con_app
| otherwise = con_app
con_app = mkConApp pack_con (map Type tycon_args ++
map Var unpacked_args)
(binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
(NonRec arg coerce : binds, unpacked_args ++ args')
(NonRec arg con_app : binds, unpacked_args ++ args')
| otherwise
= let (binds, args') = rebuildConArgs args stricts us
......@@ -558,12 +536,17 @@ ToDo: unify with mkRecordSelId.
\begin{code}
mkDictSelId :: Name -> Class -> Id
mkDictSelId name clas
= sel_id
= mkGlobalId (RecordSelId field_lbl) name sel_ty info
where
ty = exprType rhs
sel_id = mkGlobalId (RecordSelId field_lbl) name ty info
field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
-- We can't just say (exprType rhs), because that would give a type
-- C a -> C a
-- for a single-op class (after all, the selector is the identity)
-- But it's type must expose the representation of the dictionary
-- to gat (say) C a -> (a -> a)
field_lbl = mkFieldLabel name tycon sel_ty tag
tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
info = noCafNoTyGenIdInfo
`setCgArity` 1
......@@ -583,14 +566,20 @@ mkDictSelId name clas
arg_tys = dataConArgTys data_con tyvar_tys
the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
dict_ty = mkDictTy clas tyvar_tys
(dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys)
pred = mkClassPred clas tyvar_tys
(dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
Note (Coerce (head arg_tys) dict_ty) (Var dict_id)
rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
mkNewTypeBody tycon (head arg_tys) dict_id
| otherwise = mkLams tyvars $ Lam dict_id $
Case (Var dict_id) dict_id
[(DataAlt data_con, arg_ids, Var the_arg_id)]
mkNewTypeBody tycon result_ty result_id
| isRecursiveTyCon tycon -- Recursive case; use a coerce
= Note (Coerce result_ty (idType result_id)) (Var result_id)
| otherwise -- Normal case
= Var result_id
\end{code}
......@@ -647,8 +636,8 @@ mkFCallId uniq fcall ty
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
(_, tau) = splitForAllTys ty
(arg_tys, _) = splitFunTys tau
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False)
\end{code}
......
......@@ -27,7 +27,8 @@ import Id ( Id, idType, idSpecialisation )
import NameSet
import VarSet
import Var ( Var, isId, isLocalVar, varName )
import Type ( tyVarsOfType, namesOfType )
import Type ( tyVarsOfType )
import TcType ( namesOfType )
import Util ( mapAndUnzip )
import Outputable
\end{code}
......
......@@ -17,7 +17,7 @@ import IO ( hPutStr, hPutStrLn, stdout )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars )
import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Bag
import Literal ( literalType )
......@@ -31,7 +31,7 @@ import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( Type, tyVarsOfType,
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
......@@ -304,7 +304,7 @@ lintCoreExpr e@(Case scrut var alts)
addInScopeVars [var] (
-- Check the alternatives
checkAllCasesCovered e scrut_ty alts `seqL`
checkCaseAlts e scrut_ty alts `seqL`
mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
mapL (check alt_ty) alt_tys `seqL`
......@@ -396,46 +396,30 @@ lintTyApps fun_ty (arg_ty : arg_tys)
%************************************************************************
\begin{code}
checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
checkAllCasesCovered e scrut_ty alts
= case splitTyConApp_maybe scrut_ty of {
Nothing -> addErrL (badAltsMsg e);
Just (tycon, tycon_arg_tys) ->
if isPrimTyCon tycon then
checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
else
{- No longer needed
#ifdef DEBUG
-- Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
-- possibly match.
-- This code just emits a message to say so
let
missing_cons = filter not_in_alts (tyConDataCons tycon)
not_in_alts con = all (not_in_alt con) alts
not_in_alt con (DataCon con', _, _) = con /= con'
not_in_alt con other = True
checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
-- a) Check that the alts are non-empty
-- b) Check that the DEFAULT comes first, if it exists
-- c) Check that there's a default for infinite types
-- NB: Algebraic cases are not necessarily exhaustive, because
-- the simplifer correctly eliminates case that can't
-- possibly match.
checkCaseAlts e ty []
= addErrL (mkNullAltsMsg e)
checkCaseAlts e ty alts
= checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
checkL (isJust maybe_deflt || not is_infinite_ty)
(nonExhaustiveAltsMsg e)
where
(con_alts, maybe_deflt) = findDefault alts
case_bndr = case e of { Case _ bndr alts -> bndr }
in
if not (hasDefault alts || null missing_cons) then
pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
(ppr case_bndr <+> ppr missing_cons)
nopL
else
#endif
-}
nopL }
hasDefault [] = False
hasDefault ((DEFAULT,_,_) : alts) = True
hasDefault (alt : alts) = hasDefault alts
non_deflt (DEFAULT, _, _) = False
non_deflt alt = True
is_infinite_ty = case splitTyConApp_maybe ty of
Nothing -> False
Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
\end{code}
\begin{code}
......@@ -611,8 +595,8 @@ checkTys :: Type -> Type -> Message -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
checkTys ty1 ty2 msg
| ty1 == ty2 = nopL
| otherwise = addErrL msg
| ty1 `eqType` ty2 = nopL
| otherwise = addErrL msg
\end{code}
......@@ -677,15 +661,13 @@ mkScrutMsg var scrut_ty
text "Result binder type:" <+> ppr (idType var),
text "Scrutinee type:" <+> ppr scrut_ty]
badAltsMsg :: CoreExpr -> Message
badAltsMsg e
= hang (text "Case statement scrutinee is not a data type:")
4 (ppr e)
mkNonDefltMsg e
= hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
= hang (text "Case expression with non-exhaustive alternatives")
4 (ppr e)
= hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
......
......@@ -16,7 +16,7 @@ import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, seqType )
uaUTy, usOnce, usMany, eqUsage, seqType )
import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
......@@ -493,14 +493,13 @@ rhs is strict --- but that would defeat the purpose of seq and par.
\begin{code}
mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
-- DEFAULT alt is always first
= case isPrimOpId_maybe fn of
Just ParOp -> Case scrut bndr [deflt_alt]
Just SeqOp -> Case arg new_bndr [deflt_alt]
other -> Case scrut bndr alts
where
(deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
-- The binder shouldn't be used in the expression!
new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
setIdType bndr (exprType arg)
......@@ -539,9 +538,9 @@ isOnceTy ty
once
where
u = uaUTy ty
once | u == usOnce = True
| u == usMany = False
| isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
once | u `eqUsage` usOnce = True
| u `eqUsage` usMany = False
| isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
bdrDem :: Id -> RhsDemand
bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
......
......@@ -90,14 +90,16 @@ collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) =
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef:tdefs
where
tdef =
case newTyConRep tcon of
Just rep ->
C.Newtype (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (make_ty rep)
Nothing ->
C.Data (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (map make_cdef (tyConDataCons tcon))
collect_tdefs tcon tdefs
| isAlgTyCon tcon = tdef : tdefs
where
tdef | isNewTyCon tcon
= C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) (make_ty rep)
| otherwise
= C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon))
(_, rep) = newTyConRep tcon
tyvars = tyConTyVars tcon
collect_tdefs _ tdefs = tdefs
......@@ -173,16 +175,16 @@ make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty (PredTy p) = make_ty (predRepTy p)
make_ty (SourceTy p) = make_ty (sourceTypeRep p)
make_ty (UsageTy _ t) = make_ty t
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 == liftedTypeKind = C.Klifted
make_kind k | k == unliftedTypeKind = C.Kunlifted
make_kind k | k == openTypeKind = C.Kopen
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 _ = error "MkExternalCore died: make_kind"
{- Id generation. -}
......
......@@ -43,8 +43,9 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
)
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( ThetaType, PredType(..),
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
import Type ( ThetaType, SourceType(..), PredType,
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy,
getTyVar_maybe
)
import VarSet
import VarEnv
......@@ -381,8 +382,11 @@ mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst
mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv)
zip_ty_env [] [] env = env
zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) )
zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
zip_ty_env (tv:tvs) (ty:tys) env
| Just tv' <- getTyVar_maybe ty, tv==tv' = zip_ty_env tvs tys env
-- Shortcut for the (I think not uncommon) case where we are
-- making an identity substitution
| otherwise = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty))
\end{code}
substTy works with general Substs, so that it can be called from substExpr too.
......@@ -398,8 +402,11 @@ substTheta subst theta
| otherwise = map (substPred subst) theta
substPred :: TyVarSubst -> PredType -> PredType
substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
substPred = substSourceType
substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty)
substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys)
subst_ty subst ty
= go ty
......@@ -407,7 +414,7 @@ subst_ty subst ty
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
go (PredTy p) = PredTy $! (substPred subst p)
go (SourceTy p) = SourceTy $! (substSourceType subst p)
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
......
......@@ -12,6 +12,7 @@ module Check ( check , ExhaustivePat ) where
import HsSyn
import TcHsSyn ( TypecheckedPat )
import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
import DsHsSyn ( outPatType )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
......@@ -20,7 +21,7 @@ import Id ( idType )