# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.54 1999/04/13 08:55:52 kglynn Exp $
+# $Id: Makefile,v 1.55 1999/05/11 16:37:29 keithw Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
- reader profiling parser cprAnalysis
+ reader profiling parser usageSP cprAnalysis
ifeq ($(GhcWithNativeCodeGen),YES)
# Heap was 6m with 2.10
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
-rename/ParseIface_HC_OPTS += -Onot -H45m -fno-warn-incomplete-patterns
+rename/ParseIface_HC_OPTS += -Onot -H45m -dcore-lint -fno-warn-incomplete-patterns
rename/ParseIface_HAPPY_OPTS += -g
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
import TysWiredIn ( boolTy )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
- isUnLiftedType, substTopTheta,
- splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
- splitFunTys, splitForAllTys
+ mkForAllTys, isUnLiftedType, substTopTheta,
+ splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, unUsgTy,
)
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
import Class ( Class, classBigSig, classTyCon )
mkWorkerOcc, mkSuperDictSelOcc,
Name, NamedThing(..),
)
-import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq )
+import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpUniq )
import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
dataConArgTys, dataConSig, dataConRawArgTys
)
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type rhs_ty, mkStringLit full_msg]
+ error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy rhs_ty), mkStringLit full_msg]
+ -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
where
occ_name = primOpOcc prim_op
key = primOpUniq prim_op
- ty = primOpType prim_op
+ (tyvars,arg_tys,res_ty) = primOpSig prim_op
+ ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkWiredInIdName key pREL_GHC occ_name id
id = mkId name ty (ConstantId (PrimOp prim_op)) info
unfolding = mkUnfolding rhs
- (tyvars, tau) = splitForAllTys ty
- (arg_tys, _) = splitFunTys tau
-
args = mkTemplateLocals arg_tys
rhs = mkLams tyvars $ mkLams args $
mkPrimApp prim_op (map Type (mkTyVarTys tyvars) ++ map Var args)
uniqFromSupply, uniqsFromSupply, -- basic ops
UniqSM, -- type: unique supply monad
- initUs, thenUs, thenUs_, returnUs, fixUs, getUs, setUs,
+ initUs, initUs_, thenUs, thenUs_, returnUs, fixUs, getUs, setUs,
getUniqueUs, getUniquesUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs,
\begin{code}
type UniqSM result = UniqSupply -> (result, UniqSupply)
--- the initUs function also returns the final UniqSupply
+-- the initUs function also returns the final UniqSupply; initUs_ drops it
+initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
+initUs init_us m = case m init_us of { (r,us) -> (r,us) }
-initUs :: UniqSupply -> UniqSM a -> a
-
-initUs init_us m = case m init_us of { (r,_) -> r }
+initUs_ :: UniqSupply -> UniqSM a -> a
+initUs_ init_us m = case m init_us of { (r,us) -> r }
{-# INLINE thenUs #-}
{-# INLINE returnUs #-}
-
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{@Vars@: Variables}
newMutTyVar, newSigTyVar,
readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable,
+ -- UVars
+ UVar,
+ isUVar,
+ mkUVar,
+
-- Ids
Id, DictId,
idDetails, idName, idType, idUnique, idInfo, modifyIdInfo,
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
Bool -- True <=> this is a type signature variable, which
-- should not be unified with a non-tyvar type
+ | UVar -- Usage variable
-- 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.
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
-\end{code}
-\begin{code}
isTyVar :: Var -> Bool
isTyVar (Var {varDetails = details}) = case details of
TyVar -> True
%************************************************************************
%* *
+\subsection{Usage variables}
+%* *
+%************************************************************************
+
+\begin{code}
+type UVar = Var
+\end{code}
+
+\begin{code}
+mkUVar :: Unique -> UVar
+mkUVar unique = Var { varName = mkSysLocalName unique SLIT("u"),
+ realUnique = getKey unique,
+ varDetails = UVar }
+\end{code}
+
+\begin{code}
+isUVar :: Var -> Bool
+isUVar (Var {varDetails = details}) = case details of
+ UVar -> True
+ other -> False
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Id Construction}
%* *
%************************************************************************
- Most Id-related functions are in Id.lhs and MkId.lhs
+Most Id-related functions are in Id.lhs and MkId.lhs
\begin{code}
type Id = Var
extendVarEnv, extendVarEnvList,
plusVarEnv, plusVarEnv_C,
delVarEnvList, delVarEnv,
- lookupVarEnv, lookupVarEnv_NF,
+ lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
isEmptyVarEnv :: VarEnv a -> Bool
lookupVarEnv :: VarEnv a -> Var -> Maybe a
lookupVarEnv_NF :: VarEnv a -> Var -> a
+lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a
elemVarEnv :: Var -> VarEnv a -> Bool
foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
\end{code}
delVarEnv = delFromUFM
plusVarEnv = plusUFM
lookupVarEnv = lookupUFM
+lookupWithDefaultVarEnv = lookupWithDefaultUFM
mapVarEnv = mapUFM
mkVarEnv = listToUFM
emptyVarEnv = emptyUFM
import CostCentre ( CostCentre, isDupdCC, noCostCentre )
import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
import Id ( mkWildId, getInlinePragma )
-import Type ( Type, mkTyVarTy, isUnLiftedType )
+import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType )
import IdInfo ( InlinePragInfo(..) )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
| InlineCall -- Instructs simplifier to inline
-- the enclosed call
+
+ | TermUsg -- A term-level usage annotation
+ UsageAnn -- (should not be a variable except during UsageSP inference)
\end{code}
getIdArity, idFreeTyVars,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
- getIdUnfolding, setIdUnfolding
+ getIdUnfolding, setIdUnfolding, idInfo
)
-import IdInfo ( arityLowerBound, InlinePragInfo(..) )
+import IdInfo ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
import SpecEnv ( emptySpecEnv, specEnvToList, isEmptySpecEnv )
import CostCentre ( CostCentre )
import Const ( Con, conType )
import Type ( Type, TyVarSubst, mkFunTy, mkForAllTy,
splitFunTy_maybe, applyTys, tyVarsOfType, tyVarsOfTypes,
+ isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
fullSubstTy, substTyVar )
import Unique ( buildIdKey, augmentIdKey )
import Util ( zipWithEqual, mapAccumL )
import Outputable
-import TysPrim ( alphaTy ) -- Debgging only
+import TysPrim ( alphaTy ) -- Debugging only
\end{code}
coreExprType (Let _ body) = coreExprType body
coreExprType (Case _ _ alts) = coreAltsType alts
coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
coreExprType (Note other_note e) = coreExprType e
coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
coreExprType (Lam binder expr)
- | isId binder = idType binder `mkFunTy` coreExprType expr
+ | isId binder = (case (lbvarInfo . idInfo) binder of
+ IsOneShotLambda -> mkUsgTy UsOnce
+ otherwise -> id) $
+ idType binder `mkFunTy` coreExprType expr
| isTyVar binder = mkForAllTy binder (coreExprType expr)
coreExprType e@(App _ _)
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
+ ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
applyTypeToArgs e (applyTys op_ty tys) rest_args
where
(tys, rest_args) = go [ty] args
ppr_expr pe (Note InlineCall expr)
= ptext SLIT("__inline") <+> ppr_parend_expr pe expr
+ppr_expr pe (Note (TermUsg u) expr)
+ = \ sty ->
+ if ifaceStyle sty then
+ ppr_expr pe expr sty
+ else
+ (ppr u <+> ppr_expr pe expr) sty
+
ppr_case_pat pe con@(DataCon dc) args
| isTupleCon dc
= parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
import Type ( splitFunTys, mkTyConApp,
- splitAlgTyConApp, splitTyConApp_maybe,
+ splitAlgTyConApp, splitTyConApp_maybe, isNotUsgTy, unUsgTy,
splitAppTy, isUnLiftedType, Type
)
import TysWiredIn ( tupleCon, unboxedTupleCon,
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
+ ASSERT( isNotUsgTy ty )
returnDs (mkConApp consDataCon [Type ty, core_x, core_xs])
dsExpr (ExplicitTuple expr_list boxed)
returnDs (mkConApp ((if boxed
then tupleCon
else unboxedTupleCon) (length expr_list))
- (map (Type . coreExprType) core_exprs ++ core_exprs))
+ (map (Type . unUsgTy . coreExprType) core_exprs ++ core_exprs))
+ -- the above unUsgTy is *required* -- KSW 1999-04-07
dsExpr (HsCon con_id [ty] [arg])
| isNewTyCon tycon
= dsExpr arg `thenDs` \ arg' ->
- returnDs (Note (Coerce result_ty (coreExprType arg')) arg')
+ returnDs (Note (Coerce result_ty (unUsgTy (coreExprType arg'))) arg')
where
result_ty = mkTyConApp tycon [ty]
tycon = dataConTyCon con_id
dsExpr (HsCon con_id tys args)
= mapDs dsExpr args `thenDs` \ args2 ->
+ ASSERT( all isNotUsgTy tys )
returnDs (mkConApp con_id (map Type tys ++ args2))
dsExpr (ArithSeqOut expr (From from))
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ let msg = ASSERT( isNotUsgTy b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
let
(_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy)
- msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
+ ASSERT2( isNotUsgTy b_ty, ppr b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn)
(Just result_ty) locn
import TcHsSyn ( TypecheckedPat )
import TcEnv ( ValueEnv )
import Type ( Type )
-import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
+import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import UniqFM ( lookupWithDefaultUFM )
uniqSMtoDsM :: UniqSM a -> DsM a
uniqSMtoDsM u_action us genv loc mod_and_grp warns
- = (initUs us u_action, warns)
+ = (initUs_ us u_action, warns)
getSrcLocDs :: DsM SrcLoc
getSrcLocDs us genv loc mod_and_grp warns
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConStrictMarks, dataConArgTys )
import BasicTypes ( StrictnessMark(..) )
-import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
+import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
Type
)
import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon )
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
in
- returnDs (mkApps (Var err_id) [Type ty, mkStringLit full_msg])
+ returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
+ -- unUsgTy *required* -- KSW 1999-04-07
\end{code}
%************************************************************************
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
-has only one element, it is the identity function.
+has only one element, it is the identity function. Notice we must
+throw out any usage annotation on the outside of an Id.
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
mkTupleExpr [] = mkConApp unitDataCon []
mkTupleExpr [id] = Var id
mkTupleExpr ids = mkConApp (tupleCon (length ids))
- (map (Type . idType) ids ++ [ Var i | i <- ids ])
+ (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
\end{code}
#include "HsVersions.h"
-import Type ( Kind )
+import Type ( Kind, UsageAnn(..) )
import PprType ( {- instance Outputable Kind -} )
import Outputable
import Util ( thenCmp, cmpList )
| MonoTupleTy [HsType name] -- Element types (length gives arity)
Bool -- boxed?
- -- these next two are only used in unfoldings in interfaces
+ -- these next two are only used in interfaces
| MonoDictTy name -- Class
[HsType name]
+ | MonoUsgTy UsageAnn
+ (HsType name)
+
mkHsForAllTy [] [] ty = ty
mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
= ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
+
+ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
+ = maybeParen (ctxt_prec >= pREC_CON) $
+ ppr u <+> ppr_mono_ty pREC_CON ty
\end{code}
cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
+ = cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
+
cmpHsType cmp ty1 ty2 -- tags must be different
= let tag1 = tag ty1
tag2 = tag ty2
tag (MonoTyApp tc1 tys1) = ILIT(4)
tag (MonoFunTy a1 b1) = ILIT(5)
tag (MonoDictTy c1 tys1) = ILIT(7)
+ tag (MonoUsgTy c1 tys1) = ILIT(6)
tag (HsForAllTy _ _ _) = ILIT(8)
-------------------
cmp_ctxt (c1, tys1) (c2, tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+-- Should be in Type, perhaps
+cmpUsg UsOnce UsOnce = EQ
+cmpUsg UsOnce UsMany = LT
+cmpUsg UsMany UsOnce = GT
+cmpUsg UsMany UsMany = EQ
+cmpUsg u1 u2 = pprPanic "cmpUsg:" $
+ ppr u1 <+> ppr u2
+
-- Should be in Maybes, I guess
cmpMaybe cmp Nothing Nothing = EQ
cmpMaybe cmp Nothing (Just x) = LT
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ioDataCon_RDR,
+ main_RDR,
+
mkTupConRdrName, mkUbxTupConRdrName
) where
openAlphaTy = mkTyVarTy openAlphaTyVar
errorTy :: Type
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+errorTy = mkUsgTy UsMany $
+ mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkUsgTy UsOnce (mkListTy charTy)]
+ (mkUsgTy UsMany openAlphaTy))
-- Notice the openAlphaTyVar. It says that "error" can be applied
-- to unboxed as well as boxed types. This is OK because it never
-- returns, so the return type is irrelevant.
module PrimOp (
PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
- primOpType,
+ primOpType, primOpSig, primOpUsg,
primOpUniq, primOpOcc,
commutableOp,
import PprType ( pprParendType )
import OccName ( OccName, pprOccName, mkSrcVarOcc )
import TyCon ( TyCon, tyConArity )
-import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
+import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
mkTyConTy, mkTyConApp, typePrimRep,
- splitAlgTyConApp, Type, isUnboxedTupleType,
- splitAlgTyConApp_maybe
+ splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
+ UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
import Outputable
-import Util ( assoc )
+import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
\end{code}
%* *
%************************************************************************
+\begin{verbatim}
+newArray# :: Int# -> a -> State# s -> (# State# s, MutArr# s a #)
+newFooArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #)
+\end{verbatim}
+
\begin{code}
primOpInfo NewArrayOp
= let {
---------------------------------------------------------------------------
+{-
+sameMutableArray# :: MutArr# s a -> MutArr# s a -> Bool
+sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool
+-}
+
primOpInfo SameMutableArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
---------------------------------------------------------------------------
-- Primitive arrays of Haskell pointers:
+{-
+readArray# :: MutArr# s a -> Int# -> State# s -> (# State# s, a #)
+writeArray# :: MutArr# s a -> Int# -> a -> State# s -> State# s
+indexArray# :: Array# a -> Int# -> (# a #)
+-}
+
primOpInfo ReadArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
(mkStatePrimTy s)
---------------------------------------------------------------------------
+{-
+unsafeFreezeArray# :: MutArr# s a -> State# s -> (# State# s, Array# a #)
+unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (# State# s, ByteArray# #)
+unsafeThawArray# :: Array# a -> State# s -> (# State# s, MutArr# s a #)
+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutByteArr# s #)
+-}
+
primOpInfo UnsafeFreezeArrayOp
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
%* *
%************************************************************************
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch :: a -> (b -> a) -> a
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch# :: a -> (b -> a) -> a
\begin{code}
primOpInfo CatchOp
[alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
--- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
+-- killThread# :: ThreadId# -> exception -> State# RealWorld -> State# RealWorld
primOpInfo KillThreadOp
= mkGenPrimOp SLIT("killThread#") [alphaTyVar]
[threadIdPrimTy, alphaTy, realWorldStatePrimTy]
routines.
\begin{verbatim}
-makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, a #)
+makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)
freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld
deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#
-- HWL: The first 4 Int# in all par... annotations denote:
-- name, granularity info, size of result, degree of parallelism
-- Same structure as _seq_ i.e. returns Int#
+-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine
+-- `the processor containing the expression v'; it is not evaluated
-primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParGlobalOp -- parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParLocalOp -- parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+primOpInfo ParAtOp -- parAt# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParAtAbsOp -- parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+primOpInfo ParAtRelOp -- parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+primOpInfo ParAtForNowOp -- parAtForNow# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
= mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-primOpInfo CopyableOp -- copyable# :: a -> a
+primOpInfo CopyableOp -- copyable# :: a -> Int#
= mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
-primOpInfo NoFollowOp -- noFollow# :: a -> a
+primOpInfo NoFollowOp -- noFollow# :: a -> Int#
= mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
primOpUniq :: PrimOp -> Unique
primOpUniq op = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
-primOpType :: PrimOp -> Type
+primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
Dyadic occ ty -> dyadic_fun_ty ty
GenPrimOp occ tyvars arg_tys res_ty ->
mkForAllTys tyvars (mkFunTys arg_tys res_ty)
+
+-- primOpSig is like primOpType but gives the result split apart:
+-- (type variables, argument types, result type)
+
+primOpSig :: PrimOp -> ([TyVar],[Type],Type)
+primOpSig op
+ = case (primOpInfo op) of
+ Monadic occ ty -> ([], [ty], ty )
+ Dyadic occ ty -> ([], [ty,ty], ty )
+ Compare occ ty -> ([], [ty,ty], boolTy)
+ GenPrimOp occ tyvars arg_tys res_ty
+ -> (tyvars, arg_tys, res_ty)
+
+-- primOpUsg is like primOpSig but the types it yields are the
+-- appropriate sigma (i.e., usage-annotated) types,
+-- as required by the UsageSP inference.
+
+primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
+primOpUsg op
+ = case op of
+
+ -- Refer to comment by `otherwise' clause; we need consider here
+ -- *only* primops that have arguments or results containing Haskell
+ -- pointers (things that are pointed). Unpointed values are
+ -- irrelevant to the usage analysis. The issue is whether pointed
+ -- values may be entered or duplicated by the primop.
+
+ -- Remember that primops are *never* partially applied.
+
+ NewArrayOp -> mangle [mkP, mkM, mkP ] mkM
+ SameMutableArrayOp -> mangle [mkP, mkP ] mkM
+ ReadArrayOp -> mangle [mkM, mkP, mkP ] mkM
+ WriteArrayOp -> mangle [mkM, mkP, mkM, mkP] mkR
+ IndexArrayOp -> mangle [mkM, mkP ] mkM
+ UnsafeFreezeArrayOp -> mangle [mkM, mkP ] mkM
+ UnsafeThawArrayOp -> mangle [mkM, mkP ] mkM
+
+ NewMutVarOp -> mangle [mkM, mkP ] mkM
+ ReadMutVarOp -> mangle [mkM, mkP ] mkM
+ WriteMutVarOp -> mangle [mkM, mkM, mkP ] mkR
+ SameMutVarOp -> mangle [mkP, mkP ] mkM
+
+ CatchOp -> -- [mkO, mkO . (inFun mkM mkO)] mkO
+ mangle [mkM, mkM . (inFun mkM mkM)] mkM
+ -- might use caught action multiply
+ RaiseOp -> mangle [mkM ] mkM
+
+ NewMVarOp -> mangle [mkP ] mkR
+ TakeMVarOp -> mangle [mkM, mkP ] mkM
+ PutMVarOp -> mangle [mkM, mkM, mkP ] mkR
+ SameMVarOp -> mangle [mkP, mkP ] mkM
+ IsEmptyMVarOp -> mangle [mkP, mkP ] mkM
+
+ ForkOp -> mangle [mkO, mkP ] mkR
+ KillThreadOp -> mangle [mkP, mkM, mkP ] mkR
+
+ MkWeakOp -> mangle [mkZ, mkM, mkM, mkP] mkM
+ DeRefWeakOp -> mangle [mkM, mkP ] mkM
+ FinalizeWeakOp -> mangle [mkM, mkP ] (mkR . (inUB [id,id,inFun mkR mkM]))
+
+ MakeStablePtrOp -> mangle [mkM, mkP ] mkM
+ DeRefStablePtrOp -> mangle [mkM, mkP ] mkM
+ EqStablePtrOp -> mangle [mkP, mkP ] mkR
+ MakeStableNameOp -> mangle [mkZ, mkP ] mkR
+ EqStableNameOp -> mangle [mkP, mkP ] mkR
+ StableNameToIntOp -> mangle [mkP ] mkR
+
+ ReallyUnsafePtrEqualityOp -> mangle [mkZ, mkZ ] mkR
+
+ SeqOp -> mangle [mkO ] mkR
+ ParOp -> mangle [mkO ] mkR
+ ParGlobalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParLocalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtAbsOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtRelOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
+ ParAtForNowOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
+ CopyableOp -> mangle [mkZ ] mkR
+ NoFollowOp -> mangle [mkZ ] mkR
+
+ CCallOp _ _ _ _ -> mangle [ ] mkM
+
+ -- Things with no Haskell pointers inside: in actuality, usages are
+ -- irrelevant here (hence it doesn't matter that some of these
+ -- apparently permit duplication; since such arguments are never
+ -- ENTERed anyway, the usage annotation they get is entirely irrelevant
+ -- except insofar as it propagates to infect other values that *are*
+ -- pointed.
+
+ otherwise -> nomangle
+
+ where mkZ = mkUsgTy UsOnce -- pointed argument used zero
+ mkO = mkUsgTy UsOnce -- pointed argument used once
+ mkM = mkUsgTy UsMany -- pointed argument used multiply
+ mkP = mkUsgTy UsOnce -- unpointed argument
+ mkR = mkUsgTy UsMany -- unpointed result
+
+ (tyvars, arg_tys, res_ty)
+ = primOpSig op
+
+ nomangle = (tyvars, map mkP arg_tys, mkR res_ty)
+
+ mangle fs g = (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)
+
+ inFun f g ty = case splitFunTy_maybe ty of
+ Just (a,b) -> mkFunTy (f a) (g b)
+ Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
+
+ inUB fs ty = case splitTyConApp_maybe ty of
+ Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
+ mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"
+ ($) fs tys)
+ Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)
\end{code}
\begin{code}
| ITlit_lit
| ITstring_lit
| ITtypeapp
+ | ITonce -- usage annotations
+ | ITmany
| ITarity
| ITspecialise
| ITnocaf
("__litlit", ITlit_lit),
("__string", ITstring_lit),
("__a", ITtypeapp),
+ ("__o", ITonce),
+ ("__m", ITmany),
("__A", ITarity),
("__P", ITspecialise),
("__C", ITnocaf),
extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys
+extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
extract_ty (MonoTyVar tv) acc = insertTV tv acc
extract_ty (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import HsPragmas ( noDataPragmas, noClassPragmas )
-import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
+import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind, UsageAnn(..) )
import IdInfo ( ArityInfo, exactArity, CprInfo(..) )
import Lex
'__scc' { ITscc }
'__sccC' { ITsccAllCafs }
+ '__o' { ITonce }
+ '__m' { ITmany }
+
'__A' { ITarity }
'__P' { ITspecialise }
'__C' { ITnocaf }
btype :: { RdrNameHsType }
btype : atype { $1 }
| btype atype { MonoTyApp $1 $2 }
+ | '__o' atype { MonoUsgTy UsOnce $2 }
+ | '__m' atype { MonoUsgTy UsMany $2 }
atype :: { RdrNameHsType }
atype : qtc_name { MonoTyVar $1 }
rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
+rnHsType doc (MonoUsgTy usg ty)
+ = rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (MonoUsgTy usg ty', fvs)
+
rnHsTypes doc tys
= mapAndUnzipRn (rnHsType doc) tys `thenRn` \ (tys, fvs_s) ->
returnRn (tys, plusFVs fvs_s)
fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
= -- Just float in past coercion
Note note (fiExpr to_drop expr)
+
+fiExpr to_drop (_, AnnNote note@(TermUsg _) expr)
+ = -- Float in past term usage annotation
+ -- (for now; not sure if this is correct: KSW 1999-05)
+ Note note (fiExpr to_drop expr)
\end{code}
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
import Type ( isUnLiftedType, mkTyVarTys, mkForAllTys, Type )
import VarSet
import VarEnv
-import UniqSupply ( initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
+import UniqSupply ( initUs_, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
mapAndUnzip3Us, UniqSM, UniqSupply )
import Maybes ( maybeToBool )
import Util ( zipWithEqual, zipEqual )
\begin{code}
type LvlM result = UniqSM result
-initLvl = initUs
+initLvl = initUs_
thenLvl = thenUs
returnLvl = returnUs
mapLvl = mapUs
opt_D_simplifier_stats,
opt_D_dump_simpl,
opt_D_verbose_core2core,
- opt_D_dump_occur_anal
+ opt_D_dump_occur_anal,
+ opt_UsageSPOn,
)
import CoreLint ( beginPass, endPass )
import CoreSyn
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecEnv ( specEnvToList, specEnvFromList )
+import UsageSPInf ( doUsageSPInf )
import StrictAnal ( saBinds )
import WorkWrap ( wwTopBinds )
import CprAnalyse ( cprAnalyse )
core2core core_todos module_name classes us binds
= do
- let (us1, us2) = splitUniqSupply us
+ let (us1, us23) = splitUniqSupply us
+ (us2, us3 ) = splitUniqSupply us23
-- Do the main business
processed_binds <- doCorePasses us1 binds core_todos
post_simpl_binds <- doPostSimplification us2 processed_binds
-- Do the final tidy-up
- final_binds <- tidyCorePgm module_name classes post_simpl_binds
+ final_binds <- tidyCorePgm us3 module_name classes post_simpl_binds
-- Return results
return final_binds
doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saBinds binds
doCorePass us binds CoreDoWorkerWrapper = _scc_ "CoreWorkWrap" wwTopBinds us binds
doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
+doCorePass us binds CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf"
+ if opt_UsageSPOn then
+ doUsageSPInf us binds
+ else
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
+ return binds
doCorePass us binds CoreDoCPResult = _scc_ "CPResult" cprAnalyse binds
-doCorePass us binds CoreDoPrintCore = _scc_ "PrintCore" do
- putStr (showSDoc $ pprCoreBindings binds)
- return binds
+doCorePass us binds CoreDoPrintCore
+ = _scc_ "PrintCore"
+ do
+ putStr (showSDoc $ pprCoreBindings binds)
+ return binds
\end{code}
change the uniques, because the code generator makes global labels
from the uniques for local thunks etc.]
+3. If @opt_UsageSPOn@ then compute usage information (which is
+ needed by Core2Stg). ** NOTE _scc_ HERE **
\begin{code}
-tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
-tidyCorePgm mod local_classes binds_in
+tidyCorePgm :: UniqSupply -> Module -> [Class] -> [CoreBind] -> IO [CoreBind]
+tidyCorePgm us mod local_classes binds_in
= do
beginPass "Tidy Core"
- let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
+ let (_, binds_tidy) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
+ binds_out <- if opt_UsageSPOn
+ then _scc_ "CoreUsageSPInf" doUsageSPInf us binds_tidy
+ else return binds_tidy
endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
where
-- Make sure to avoid the names of class operations
import SpecEnv ( addToSpecEnv )
import UniqSupply ( UniqSupply,
- UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs,
+ UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
getUniqSupplySM = getUs
setUniqSupplySM = setUs
mapSM = mapUs
-initSM = initUs
+initSM = initUs_
mapAndCombineSM f [] = returnSM ([], emptyUDs)
mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) ->
InlinePragInfo(..), CprInfo(..) )
import Demand ( wwLazy )
import SaLib
-import UniqSupply ( UniqSupply, initUs, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import UniqSet
import WwLib
import Outputable
workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
workersAndWrappers us top_binds
- = initUs us $
+ = initUs_ us $
mapUs (wwBind True{-top-level-}) top_binds `thenUs` \ top_binds2 ->
let
top_binds3 = map make_top_binding top_binds2
import Unique ( Unique, Uniquable(..) )
import Util
import Maybes ( seqMaybe )
+import FiniteMap ( lookupWithDefaultFM )
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
%************************************************************************
\begin{code}
-tcClassDecl1 rec_env rec_inst_mapper
+tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
(ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
tycon_name datacon_name src_loc)
tycon dict_con_id
dict_con_id = mkDataConId dict_con
+ argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
+ ppr tycon_name)
+ tycon_name
+
tycon = mkAlgTyCon tycon_name
class_kind
tyvars
[] -- No context
+ argvrcs
[dict_con] -- Constructors
[] -- No derivings
(Just clas) -- Yes! It's a dictionary
TcEnv, ValueEnv, TcTyThing(..),
- initEnv, getEnvTyCons, getEnvClasses,
+ initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
splitAlgTyConApp_maybe, getTyVar
)
+import UsageSPUtils ( unannotTy )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon )
-import Class ( Class )
+import Class ( Class, classTyCon )
import TcMonad
import Unique ( Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import Bag ( bagToList )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, catMaybes )
import SrcLoc ( SrcLoc )
import FastString ( FastString )
import Outputable
TcType) --
tcInstId id
= let
- (tyvars, rho) = splitForAllTys (idType id)
+ (tyvars, rho) = splitForAllTys (unannotTy (idType id))
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
let
returnNF_Tc (tyvars', theta', tau')
\end{code}
+Between the renamer and the first invocation of the UsageSP inference,
+identifiers read from interface files will have usage information in
+their types, whereas other identifiers will not. The unannotTy here
+in @tcInstId@ prevents this information from pointlessly propagating
+further prior to the first usage inference.
+
%************************************************************************
%* *
getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
+getAllEnvTyCons (TcEnv te _ _) = catMaybes (map gettc (eltsUFM te))
+ where
+ gettc (_,_, ATyCon tc) = Just tc
+ gettc (_,_, AClass cl) = Just (classTyCon cl)
+ gettc _ = Nothing
\end{code}
The TypeEnv
import DataCon ( dataConFieldLabels, dataConSig, dataConId )
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
- splitFunTy_maybe, splitFunTys,
+ splitFunTy_maybe, splitFunTys, isNotUsgTy,
mkTyConApp,
splitForAllTys, splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
boxedTypeKind, mkArrowKind,
substTopTheta, tidyOpenType
)
+import UsageSPUtils ( unannotTy )
import VarEnv ( zipVarEnv )
import VarSet ( elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
- (_, tau) = splitForAllTys (idType sel_id)
+ (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
+ splitForAllTys (idType sel_id)
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
(tycon, _, data_cons) = splitAlgTyConApp data_ty
(con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
%* *
%************************************************************************
+Between the renamer and the first invocation of the UsageSP inference,
+identifiers read from interface files will have usage information in
+their types, whereas other identifiers will not. The unannotTy here
+in @tcId@ prevents this information from pointlessly propagating
+further prior to the first usage inference.
+
\begin{code}
tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it tc_id (idType tc_id)
+ Just tc_id -> instantiate_it tc_id (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
_ -> returnTc ()) `thenTc_`
- tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe,
+ splitTyConApp_maybe, splitDictTy_maybe, unUsgTy,
splitAlgTyConApp_maybe,
tyVarsOfTypes, substTopTheta
)
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
+ HsApp (TyApp (HsVar eRROR_ID) [(unUsgTy . idType) this_dict_id])
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
import VarSet ( TyVarSet )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
- UniqSM, initUs )
+ UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
import FiniteMap ( FiniteMap, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
= do uniq_supply <- readIORef u_var
let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
writeIORef u_var new_uniq_supply
- return (initUs uniq_s m)
+ return (initUs_ uniq_s m)
where
u_var = getUniqSupplyVar down
\end{code}
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
import Type ( Type, ThetaType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys,
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, zipFunTys,
mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
boxedTypeKind, unboxedTypeKind, tyVarsOfType,
mkArrowKinds, getTyVar_maybe, getTyVar,
= tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
returnTc (boxedTypeKind, mkDictTy clas arg_tys)
+tc_type_kind (MonoUsgTy usg ty)
+ = tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
+ returnTc (kind, mkUsgTy usg tc_ty)
+
tc_type_kind (HsForAllTy (Just tv_names) context ty)
= tcExtendTyVarScope tv_names $ \ tyvars ->
tcContext context `thenTc` \ theta ->
import PprType ( pprType )
import Type ( Type(..), Kind, ThetaType, TyNote(..),
mkAppTy, mkTyConApp,
- splitDictTy_maybe, splitForAllTys,
+ splitDictTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
fullSubstTy, substTopTy,
typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
mk_void_tycon tv kind -- Make a new TyCon with the same kind as the
-- type variable tv. Same name too, apart from
-- making it start with a colon (sigh)
- = mkPrimTyCon tc_name kind 0 VoidRep
+ = mkPrimTyCon tc_name kind 0 [] VoidRep
where
tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations
+ go (NoteTy (UsgNote usg) ty2) = go ty2 `thenNF_Tc` \ ty2' ->
+ returnNF_Tc (NoteTy (UsgNote usg) ty2')
+
go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
go res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res')
= tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
Nothing -> unbound_var_fn tyvar -- Mutable and unbound
- Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
+ Just other_ty -> ASSERT( isNotUsgTy other_ty )
+ zonkType unbound_var_fn other_ty -- Bound
\end{code}
%************************************************************************
import TcMonad
import Type ( Type(..), tyVarsOfType, funTyCon,
mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
+ isNotUsgTy,
Kind, boxedTypeKind, typeCon, anyBoxCon, anyBoxKind,
splitAppTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar
-> TcM s ()
-- Always expand synonyms (see notes at end)
+ -- (this also throws away FTVs and usage annots)
uTys ps_ty1 (NoteTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (NoteTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
| otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
- -- Expand synonyms
+ -- Expand synonyms; ignore FTVs; ignore usage annots
uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2)
= uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
returnTc ()
else
+ ASSERT( isNotUsgTy ps_ty2 )
tcPutTyVar tv1 ps_ty2 `thenNF_Tc_`
returnTc ()
where
| otherwise
= checkKinds swapped tv1 non_var_ty2 `thenTc_`
occur_check non_var_ty2 `thenTc_`
+ ASSERT( isNotUsgTy ps_ty2 )
checkTcM (not (isSigTyVar tv1))
(failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_`
tcPutTyVar tv1 ps_ty2 `thenNF_Tc_`
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1998
+%
+\section[Type]{Type}
+
\begin{code}
module Type (
- Type(..), TyNote(..), -- Representation visible to friends
+ Type(..), TyNote(..), UsageAnn(..), -- Representation visible to friends
Kind, TyVarSubst,
superKind, superBoxity, -- :: SuperKind
mkSynTy, isSynTy, deNoteType,
+ mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
+
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy,
mkPiType,
import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
-- friends:
-import Var ( Id, TyVar, IdOrTyVar,
- tyVarKind, tyVarName, isId, idType, setTyVarName
+import Var ( Id, TyVar, IdOrTyVar, UVar,
+ tyVarKind, tyVarName, isId, idType, setTyVarName, setVarOcc
)
import VarEnv
import VarSet
with "data" or "newtype".
An algebraic type is one that can be deconstructed
with a case expression.
-
*NOT* the same as lifted types, because we also
include unboxed tuples in this classification.
data TyNote
= SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
| FTVNote TyVarSet -- The free type variables of the noted expression
+ | UsgNote UsageAnn -- The usage annotation at this node
+
+data UsageAnn
+ = UsOnce -- Used at most once
+ | UsMany -- Used possibly many times (no info; this annotation can be omitted)
+ | UsVar UVar -- Annotation is variable (should only happen inside analysis)
\end{code}
invariant: use it.
\begin{code}
-mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
+mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
-- For example: mkAppTys Rational []
-- returns to (Ratio Integer), which has needlessly lost
-- the Rational part.
-mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
+mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
- mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
+ mk_app ty1 = ASSERT2( all isNotUsgTy orig_tys2, pprType orig_ty1 <+> text "to" <+> hsep (map pprType orig_tys2) )
+ foldl AppTy orig_ty1 orig_tys2
splitAppTy_maybe :: Type -> Maybe (Type, Type)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
\end{code}
-
---------------------------------------------------------------------
TyConApp
~~~~~~~~
\begin{code}
mkSynTy syn_tycon tys
- = ASSERT(isSynTyCon syn_tycon)
+ = ASSERT( isSynTyCon syn_tycon )
+ ASSERT( isNotUsgTy body )
NoteTy (SynNote (TyConApp syn_tycon tys))
(substTopTy (zipVarEnv tyvars tys) body)
where
---------------------------------------------------------------------
+ UsgNote
+ ~~~~~~~
+
+NB: Invariant: if present, usage note is at the very top of the type.
+This should be carefully preserved.
+
+In some parts of the compiler, comments use the _Once Upon a
+Polymorphic Type_ (POPL'99) usage of "sigma = usage-annotated type;
+tau = un-usage-annotated type"; unfortunately this conflicts with the
+rho/tau/theta/sigma usage in the rest of the compiler.
+(KSW 1999-04)
+
+\begin{code}
+mkUsgTy :: UsageAnn -> Type -> Type
+#ifndef USMANY
+mkUsgTy UsMany ty = ASSERT2( isNotUsgTy ty, pprType ty )
+ ty
+#endif
+mkUsgTy usg ty = ASSERT2( isNotUsgTy ty, pprType ty )
+ NoteTy (UsgNote usg) ty
+
+-- The isUsgTy function is utterly useless if UsManys are omitted.
+-- Be warned! KSW 1999-04.
+isUsgTy :: Type -> Bool
+#ifndef USMANY
+isUsgTy _ = True
+#else
+isUsgTy (NoteTy (UsgNote _) _) = True
+isUsgTy other = False
+#endif
+
+-- The isNotUsgTy function may return a false True if UsManys are omitted;
+-- in other words, A SSERT( isNotUsgTy ty ) may be useful but
+-- A SSERT( not (isNotUsg ty) ) is asking for trouble. KSW 1999-04.
+isNotUsgTy :: Type -> Bool
+isNotUsgTy (NoteTy (UsgNote _) _) = False
+isNotUsgTy other = True
+
+-- splitUsgTy_maybe is not exported, since it is meaningless if
+-- UsManys are omitted. It is used in several places in this module,
+-- however. KSW 1999-04.
+splitUsgTy_maybe :: Type -> Maybe (UsageAnn,Type)
+splitUsgTy_maybe (NoteTy (UsgNote usg) ty2) = ASSERT( isNotUsgTy ty2 )
+ Just (usg,ty2)
+splitUsgTy_maybe ty = Nothing
+
+splitUsgTy :: Type -> (UsageAnn,Type)
+splitUsgTy ty = case splitUsgTy_maybe ty of
+ Just ans -> ans
+ Nothing ->
+#ifndef USMANY
+ (UsMany,ty)
+#else
+ pprPanic "splitUsgTy: no usage annot:" $ pprType ty
+#endif
+
+tyUsg :: Type -> UsageAnn
+tyUsg = fst . splitUsgTy
+
+unUsgTy :: Type -> Type
+-- strip outer usage annotation if present
+unUsgTy ty = case splitUsgTy_maybe ty of
+ Just (_,ty1) -> ASSERT2( isNotUsgTy ty1, pprType ty )
+ ty1
+ Nothing -> ty
+\end{code}
+
+
+
+---------------------------------------------------------------------
ForAllTy
~~~~~~~~
+We need to be clever here with usage annotations; they need to be
+lifted or lowered through the forall as appropriate.
+
\begin{code}
-mkForAllTy = ForAllTy
+mkForAllTy :: TyVar -> Type -> Type
+mkForAllTy tyvar ty = case splitUsgTy_maybe ty of
+ Just (usg,ty') -> NoteTy (UsgNote usg)
+ (ForAllTy tyvar ty')
+ Nothing -> ForAllTy tyvar ty
mkForAllTys :: [TyVar] -> Type -> Type
-mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
+mkForAllTys tyvars ty = case splitUsgTy_maybe ty of
+ Just (usg,ty') -> NoteTy (UsgNote usg)
+ (foldr ForAllTy ty' tyvars)
+ Nothing -> foldr ForAllTy ty tyvars
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
-splitForAllTy_maybe (NoteTy _ ty) = splitForAllTy_maybe ty
-splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
-splitForAllTy_maybe _ = Nothing
+splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
+ Just (usg,ty') -> do (tyvar,ty'') <- splitFAT_m ty'
+ return (tyvar, NoteTy (UsgNote usg) ty'')
+ Nothing -> splitFAT_m ty
+ where
+ splitFAT_m (NoteTy _ ty) = splitFAT_m ty
+ splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
+ splitFAT_m _ = Nothing
isForAllTy :: Type -> Bool
isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy _ = False
splitForAllTys :: Type -> ([TyVar], Type)
-splitForAllTys ty = split ty ty []
+splitForAllTys ty = case splitUsgTy_maybe ty of
+ Just (usg,ty') -> let (tvs,ty'') = split ty' ty' []
+ in (tvs, NoteTy (UsgNote usg) ty'')
+ Nothing -> split ty ty []
where
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
\begin{code}
mkPiType :: IdOrTyVar -> Type -> Type -- The more polymorphic version doesn't work...
mkPiType v ty | isId v = mkFunTy (idType v) ty
- | otherwise = ForAllTy v ty
+ | otherwise = mkForAllTy v ty
\end{code}
\begin{code}
applyTy :: Type -> Type -> Type
-applyTy (NoteTy _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty
-applyTy other arg = panic "applyTy"
+applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
+applyTy (NoteTy _ fun) arg = applyTy fun arg
+applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
+ substTy (mkVarEnv [(tv,arg)]) ty
+applyTy other arg = panic "applyTy"
applyTys :: Type -> [Type] -> Type
applyTys fun_ty arg_tys
= go [] fun_ty arg_tys
where
go env ty [] = substTy (mkVarEnv env) ty
+ go env (NoteTy note@(UsgNote _) fun)
+ args = NoteTy note (go env fun args)
go env (NoteTy _ fun) args = go env fun args
- go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
+ go env (ForAllTy tv ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat ((map pprType arg_tys) ++ [text "in application of" <+> pprType fun_ty]) )
+ go ((tv,arg):env) ty args
go env other args = panic "applyTys"
\end{code}
+Note that we allow applications to be of usage-annotated- types, as an
+extension: we handle them by lifting the annotation outside. The
+argument, however, must still be unannotated.
%************************************************************************
%* *
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
+tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
-- Add a Note with the free tyvars to the top of the type
+-- (but under a usage if there is one)
addFreeTyVars :: Type -> Type
-addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
-addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
+addFreeTyVars (NoteTy note@(UsgNote _) ty) = NoteTy note (addFreeTyVars ty)
+addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
+addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
-- Find the free names of a type, including the type constructors and classes it mentions
namesOfType :: Type -> NameSet
in args `seqList` TyConApp tc args
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ go (NoteTy (UsgNote usg) ty2) = (NoteTy $! (UsgNote usg)) $! (go ty2) -- Keep usage annot
+ go (FunTy arg res) = FunTy (go arg) (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) (go arg)
go ty@(TyVarTy tv) = case (lookupVarEnv tenv tv) of
Nothing -> ty
Just ty' -> ty'
go_note (SynNote ty) = SynNote $! (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
+ go_note note@(UsgNote _) = note -- Usage annotation is already tidy
tidyTypes env tys = map (tidyType env) tys
\end{code}
projects / ghc-hetmet.git / commitdiff