From d133b73a4d4717892ced072d05e039a54ede0ceb Mon Sep 17 00:00:00 2001 From: keithw Date: Tue, 11 May 1999 16:38:04 +0000 Subject: [PATCH] [project @ 1999-05-11 16:37:29 by keithw] (this is number 4 of 9 commits to be applied together) The major purpose of this commit is to introduce usage information and usage analysis into the compiler, per the paper _Once Upon a Polymorphic Type_ (Keith Wansbrough and Simon Peyton Jones, POPL'99, and Glasgow TR-1998-19). Usage information has been added to types, in the form of a new kind of NoteTy: (UsgNote UsageAnn(UsOnce|UsMany|UsVar UVar)). Usages print as __o (once), __m (many, usually omitted), or (not in interface files) __uvxxxx. Usage annotations should only appear at certain places in a type (see the paper). The `default' annotation is __m, and so an omitted annotation implies __m. Utility functions for handling usage annotations are provided in Type. If the compiler is built with -DUSMANY (a flag intended for use in debugging by KSW only), __m are *required* and may not be omitted. The major constraint is that type arguments (eg to mkAppTy) must be unannotated on top. To maintain this invariant, many functions required the insertion of Type.unUsgTy (removing annot from top of a type) or UsageSPUtils.unannotTy (removing all annotations from a type). A function returning usage-annotated types for primops has been added to PrimOp. A new kind of Note, (TermUsg UsageAnn), has been added to annotate Terms. This note is *not* printed in interface files, and for the present does not escape the internals of the usage inference engine. --- ghc/compiler/Makefile | 6 +- ghc/compiler/basicTypes/MkId.lhs | 16 ++- ghc/compiler/basicTypes/UniqSupply.lhs | 11 +- ghc/compiler/basicTypes/Var.lhs | 37 ++++++- ghc/compiler/basicTypes/VarEnv.lhs | 4 +- ghc/compiler/coreSyn/CoreSyn.lhs | 5 +- ghc/compiler/coreSyn/CoreUtils.lhs | 14 ++- ghc/compiler/coreSyn/PprCore.lhs | 7 ++ ghc/compiler/deSugar/DsExpr.lhs | 16 ++- ghc/compiler/deSugar/DsMonad.lhs | 4 +- ghc/compiler/deSugar/DsUtils.lhs | 10 +- ghc/compiler/hsSyn/HsTypes.lhs | 23 ++++- ghc/compiler/prelude/PrelInfo.lhs | 2 + ghc/compiler/prelude/PrelVals.lhs | 4 +- ghc/compiler/prelude/PrimOp.lhs | 174 ++++++++++++++++++++++++++++---- ghc/compiler/reader/Lex.lhs | 4 + ghc/compiler/reader/RdrHsSyn.lhs | 1 + ghc/compiler/rename/ParseIface.y | 7 +- ghc/compiler/rename/RnSource.lhs | 4 + ghc/compiler/simplCore/FloatIn.lhs | 5 + ghc/compiler/simplCore/SetLevels.lhs | 4 +- ghc/compiler/simplCore/SimplCore.lhs | 35 +++++-- ghc/compiler/specialise/Specialise.lhs | 4 +- ghc/compiler/stranal/WorkWrap.lhs | 4 +- ghc/compiler/typecheck/TcClassDcl.lhs | 8 +- ghc/compiler/typecheck/TcEnv.lhs | 20 +++- ghc/compiler/typecheck/TcExpr.lhs | 16 ++- ghc/compiler/typecheck/TcInstDcls.lhs | 4 +- ghc/compiler/typecheck/TcMonad.lhs | 4 +- ghc/compiler/typecheck/TcMonoType.lhs | 6 +- ghc/compiler/typecheck/TcType.lhs | 10 +- ghc/compiler/typecheck/TcUnify.lhs | 6 +- ghc/compiler/types/Type.lhs | 164 +++++++++++++++++++++++++----- 33 files changed, 522 insertions(+), 117 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 48401c6..6e84f3e 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $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 @@ -49,7 +49,7 @@ $(HS_PROG) :: $(HS_SRCS) 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) @@ -191,7 +191,7 @@ reader/Lex_HC_OPTS = -K2m -H16m -fvia-C # 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" diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 237b210..af3dc38 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -31,9 +31,8 @@ import {-# SOURCE #-} CoreUnfold ( mkUnfolding ) 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 ) @@ -44,7 +43,7 @@ import Name ( mkDerivedName, mkWiredInIdName, mkWorkerOcc, mkSuperDictSelOcc, Name, NamedThing(..), ) -import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq ) +import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpUniq ) import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels, dataConArgTys, dataConSig, dataConRawArgTys ) @@ -262,7 +261,8 @@ mkRecordSelId field_label selector_ty 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} @@ -378,7 +378,8 @@ mkPrimitiveId prim_op 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 @@ -391,9 +392,6 @@ mkPrimitiveId prim_op 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) diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 4b8a756..13175fb 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -11,7 +11,7 @@ module UniqSupply ( 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, @@ -113,11 +113,12 @@ uniqsFromSupply (I# i) supply = i `get_from` supply \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 #-} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 0d20b98..cacde2b 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -1,4 +1,4 @@ - +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{@Vars@: Variables} @@ -19,6 +19,11 @@ module Var ( newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable, + -- UVars + UVar, + isUVar, + mkUVar, + -- Ids Id, DictId, idDetails, idName, idType, idUnique, idInfo, modifyIdInfo, @@ -80,6 +85,7 @@ data VarDetails | 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. @@ -198,9 +204,7 @@ writeMutTyVar (Var {varDetails = MutTyVar loc _}) val = writeIORef loc val makeTyVarImmutable :: TyVar -> TyVar makeTyVarImmutable tyvar = tyvar { varDetails = TyVar} -\end{code} -\begin{code} isTyVar :: Var -> Bool isTyVar (Var {varDetails = details}) = case details of TyVar -> True @@ -219,11 +223,36 @@ isSigTyVar other = False %************************************************************************ %* * +\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 diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index 515025b..db389ef 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -11,7 +11,7 @@ module VarEnv ( extendVarEnv, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, - lookupVarEnv, lookupVarEnv_NF, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, foldVarEnv, @@ -72,6 +72,7 @@ rngVarEnv :: VarEnv a -> [a] 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} @@ -84,6 +85,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM plusVarEnv = plusUFM lookupVarEnv = lookupUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM emptyVarEnv = emptyUFM diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index a8ef5bd..e87594a 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -31,7 +31,7 @@ import TysWiredIn ( boolTy, stringTy, nilDataCon ) 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 ) @@ -79,6 +79,9 @@ data Note | 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} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 814426e..821fbff 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -32,19 +32,20 @@ import Id ( Id, idType, setIdType, idUnique, idAppIsBottom, 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} @@ -75,11 +76,15 @@ coreExprType (Var var) = idType var 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 _ _) @@ -99,6 +104,7 @@ applyTypeToArgs e op_ty [] = op_ty 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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 9972096..1e06c18 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -261,6 +261,13 @@ ppr_expr pe (Note (Coerce to_ty from_ty) expr) 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 diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 698b48a..30c8fb6 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -40,7 +40,7 @@ import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID ) 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, @@ -398,6 +398,7 @@ dsExpr (ExplicitListOut ty xs) 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) @@ -405,18 +406,20 @@ 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)) @@ -614,7 +617,8 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty 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) @@ -644,7 +648,9 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index b5821b5..fcee34d 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -38,7 +38,7 @@ import SrcLoc ( noSrcLoc, SrcLoc ) 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 ) @@ -182,7 +182,7 @@ the @SrcLoc@ being carried around. 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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index e945912..177b183 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -41,7 +41,7 @@ import Const ( Literal(..), Con(..) ) 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 ) @@ -276,7 +276,8 @@ mkErrorAppDs err_id ty msg 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} %************************************************************************ @@ -363,7 +364,8 @@ mkSelectorBinds pat val_expr @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 @@ -371,7 +373,7 @@ 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} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 74e39e1..f57cbe8 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -21,7 +21,7 @@ module HsTypes ( #include "HsVersions.h" -import Type ( Kind ) +import Type ( Kind, UsageAnn(..) ) import PprType ( {- instance Outputable Kind -} ) import Outputable import Util ( thenCmp, cmpList ) @@ -54,10 +54,13 @@ data HsType name | 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 @@ -152,6 +155,10 @@ ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_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} @@ -205,6 +212,9 @@ cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) 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 @@ -217,6 +227,7 @@ cmpHsType cmp ty1 ty2 -- tags must be different 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) ------------------- @@ -226,6 +237,14 @@ cmpContext cmp a b 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 diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 5bbd2a5..d6262e1 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -60,6 +60,8 @@ module PrelInfo ( monadClass_RDR, enumClass_RDR, ordClass_RDR, ioDataCon_RDR, + main_RDR, + mkTupConRdrName, mkUbxTupConRdrName ) where diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 16f6d9d..68b2f26 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -150,7 +150,9 @@ pAR_ERROR_ID 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. diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index dd15382..072b995 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -7,7 +7,7 @@ module PrimOp ( PrimOp(..), allThePrimOps, tagOf_PrimOp, -- ToDo: rm - primOpType, + primOpType, primOpSig, primOpUsg, primOpUniq, primOpOcc, commutableOp, @@ -33,14 +33,14 @@ import CallConv ( CallConv, pprCallConv ) 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} @@ -1214,6 +1214,11 @@ primOpInfo DoubleDecodeOp %* * %************************************************************************ +\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 { @@ -1237,6 +1242,11 @@ primOpInfo (NewByteArrayOp kind) --------------------------------------------------------------------------- +{- +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; @@ -1256,6 +1266,12 @@ primOpInfo SameMutableByteArrayOp --------------------------------------------------------------------------- -- 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; @@ -1336,6 +1352,13 @@ primOpInfo (WriteOffAddrOp kind) (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; @@ -1437,8 +1460,8 @@ primOpInfo SameMutVarOp %* * %************************************************************************ -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 @@ -1549,7 +1572,7 @@ primOpInfo ForkOp [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] @@ -1665,7 +1688,7 @@ it is safe to pass a stable pointer to external systems such as C 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# @@ -1810,29 +1833,31 @@ primOpInfo ParOp -- par# :: 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} @@ -2089,7 +2114,7 @@ primOpOcc op 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 @@ -2098,6 +2123,119 @@ primOpType op 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} diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index a8595e3..ae1ca2c 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -135,6 +135,8 @@ data IfaceToken | ITlit_lit | ITstring_lit | ITtypeapp + | ITonce -- usage annotations + | ITmany | ITarity | ITspecialise | ITnocaf @@ -617,6 +619,8 @@ ifaceKeywordsFM = listToUFM $ ("__litlit", ITlit_lit), ("__string", ITstring_lit), ("__a", ITtypeapp), + ("__o", ITonce), + ("__m", ITmany), ("__A", ITarity), ("__P", ITspecialise), ("__C", ITnocaf), diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 8091b74..4964c42 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -120,6 +120,7 @@ extract_ty (MonoListTy ty) acc = extract_ty ty acc 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 ++ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 2e7218c..49e233e 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -14,7 +14,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), ) 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 @@ -93,6 +93,9 @@ import Ratio ( (%) ) '__scc' { ITscc } '__sccC' { ITsccAllCafs } + '__o' { ITonce } + '__m' { ITmany } + '__A' { ITarity } '__P' { ITspecialise } '__C' { ITnocaf } @@ -388,6 +391,8 @@ types2 : type ',' type { [$1,$3] } 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 } diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index d4d4337..51f9ea3 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -618,6 +618,10 @@ rnHsType doc (MonoDictTy clas tys) 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) diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index a2ff239..865531a 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -199,6 +199,11 @@ fiExpr to_drop (_, AnnNote InlineCall expr) 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} diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index d277ab0..10c6de6 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -32,7 +32,7 @@ import VarSet 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 ) @@ -597,7 +597,7 @@ decideRecFloatLevel ctxt_lvl env ids rhss \begin{code} type LvlM result = UniqSM result -initLvl = initUs +initLvl = initUs_ thenLvl = thenUs returnLvl = returnUs mapLvl = mapUs diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index a763a7c..181a38a 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -15,7 +15,8 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), 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 @@ -58,6 +59,7 @@ import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) import SpecEnv ( specEnvToList, specEnvFromList ) +import UsageSPInf ( doUsageSPInf ) import StrictAnal ( saBinds ) import WorkWrap ( wwTopBinds ) import CprAnalyse ( cprAnalyse ) @@ -88,7 +90,8 @@ core2core :: [CoreToDo] -- Spec of what core-to-core passes to do 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 @@ -97,7 +100,7 @@ core2core core_todos module_name classes us binds 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 @@ -119,10 +122,19 @@ doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs 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} @@ -231,13 +243,18 @@ Several tasks are done by @tidyCorePgm@ 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 diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 080fd0e..87d41a0 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -32,7 +32,7 @@ import PprCore () -- Instances 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 ) @@ -1139,7 +1139,7 @@ getUniqSM = getUniqueUs getUniqSupplySM = getUs setUniqSupplySM = setUs mapSM = mapUs -initSM = initUs +initSM = initUs_ mapAndCombineSM f [] = returnSM ([], emptyUDs) mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) -> diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index bac9ff5..f7965b6 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -26,7 +26,7 @@ import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), 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 @@ -82,7 +82,7 @@ wwTopBinds us binds 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 diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index e3289b3..e8e9bc3 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -61,6 +61,7 @@ import TyCon ( mkAlgTyCon ) import Unique ( Unique, Uniquable(..) ) import Util import Maybes ( seqMaybe ) +import FiniteMap ( lookupWithDefaultFM ) -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) @@ -142,7 +143,7 @@ kcClassDecl (ClassDecl context class_name %************************************************************************ \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) @@ -186,10 +187,15 @@ tcClassDecl1 rec_env rec_inst_mapper 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 diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 3c63d34..25816b5 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -5,7 +5,7 @@ module TcEnv( TcEnv, ValueEnv, TcTyThing(..), - initEnv, getEnvTyCons, getEnvClasses, + initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, @@ -46,9 +46,10 @@ import Type ( Kind, superKind, 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 @@ -64,7 +65,7 @@ import UniqFM 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 @@ -106,7 +107,7 @@ tcInstId :: Id 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 @@ -116,6 +117,12 @@ tcInstId id 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. + %************************************************************************ %* * @@ -152,6 +159,11 @@ initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut) 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 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index b7ddf90..65af1e1 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -47,7 +47,7 @@ import Id ( idType, recordSelectorFieldLabel, 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, @@ -55,6 +55,7 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, boxedTypeKind, mkArrowKind, substTopTheta, tidyOpenType ) +import UsageSPUtils ( unannotTy ) import VarEnv ( zipVarEnv ) import VarSet ( elemVarSet, mkVarSet ) import TyCon ( tyConDataCons ) @@ -529,7 +530,8 @@ tcMonoExpr (RecordUpd record_expr rbinds) res_ty -- 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) @@ -795,6 +797,12 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) %* * %************************************************************************ +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) @@ -803,7 +811,7 @@ tcId name 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) -> @@ -858,7 +866,7 @@ tcDoStmts do_or_lc stmts src_loc res_ty 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, diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index cd6aff5..d99f93d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -53,7 +53,7 @@ import SrcLoc ( SrcLoc ) 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 ) @@ -440,7 +440,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys -- 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 diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index b2d0497..27abfa7 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -56,7 +56,7 @@ import Var ( TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar ) 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 ) @@ -507,7 +507,7 @@ uniqSMToTcM m down env = 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} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index a20c460..22e2a33 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -29,7 +29,7 @@ import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, 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, @@ -152,6 +152,10 @@ tc_type_kind (MonoDictTy class_name tys) = 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 -> diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index ff0a61e..48d58fe 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -54,7 +54,7 @@ module TcType ( 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 @@ -371,7 +371,7 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty 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) @@ -433,6 +433,9 @@ zonkType unbound_var_fn ty 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') @@ -463,7 +466,8 @@ zonkTyVar unbound_var_fn tyvar = 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} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index ec1189c..c136846 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -18,6 +18,7 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, import TcMonad import Type ( Type(..), tyVarsOfType, funTyCon, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe, + isNotUsgTy, Kind, boxedTypeKind, typeCon, anyBoxCon, anyBoxKind, splitAppTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar @@ -126,6 +127,7 @@ uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 -> 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 @@ -250,7 +252,7 @@ uVar swapped tv1 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 @@ -275,6 +277,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () else + ASSERT( isNotUsgTy ps_ty2 ) tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc () where @@ -292,6 +295,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 | 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_` diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index e139cdd..521c900 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -1,6 +1,11 @@ +% +% (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 @@ -29,6 +34,8 @@ module Type ( mkSynTy, isSynTy, deNoteType, + mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, + mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, mkPiType, @@ -63,8 +70,8 @@ import {-# SOURCE #-} DataCon( DataCon ) 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 @@ -119,7 +126,6 @@ A type is 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. @@ -185,6 +191,12 @@ data Type 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} @@ -348,7 +360,8 @@ invariant that a TyConApp is always visibly so. mkAppTy maintains the 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]) @@ -361,11 +374,13 @@ mkAppTys orig_ty1 [] = orig_ty1 -- 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) @@ -435,7 +450,6 @@ funResultTy ty = pprPanic "funResultTy" (pprType ty) \end{code} - --------------------------------------------------------------------- TyConApp ~~~~~~~~ @@ -519,7 +533,8 @@ isDictTy other = False \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 @@ -556,19 +571,104 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. --------------------------------------------------------------------- + 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 @@ -576,7 +676,10 @@ isForAllTy (ForAllTy tyvar ty) = True 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 @@ -589,25 +692,33 @@ it is given a type variable or a term variable. \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. %************************************************************************ %* * @@ -710,6 +821,7 @@ tyVarsOfType (TyVarTy tv) = unitVarSet tv 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 @@ -718,9 +830,11 @@ tyVarsOfTypes :: [Type] -> TyVarSet 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 @@ -795,8 +909,9 @@ subst_ty tenv tset ty 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' @@ -875,6 +990,7 @@ tidyType env@(tidy_env, subst) 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} -- 1.7.10.4