[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.

33 files changed, 522 insertions, 117 deletions

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index 48401c6148..6e84f3e923 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 237b210109..af3dc38286 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 4b8a7564f7..13175fb3b3 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 0d20b98a84..cacde2b61e 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 515025b3ed..db389ef534 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 a8ef5bd7b6..e87594a5c5 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 814426e185..821fbff52e 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 9972096551..1e06c18e07 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 698b48ad31..30c8fb6693 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 b5821b523e..fcee34d3fc 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 e945912ade..177b183e85 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 74e39e17b9..f57cbe86c8 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 5bbd2a5a40..d6262e1a95 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 16f6d9d473..68b2f26b32 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 dd15382fad..072b9955c8 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 a8595e36f8..ae1ca2c044 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 8091b74a0f..4964c420d3 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 2e7218c8a6..49e233ebbb 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 d4d43373aa..51f9ea37c8 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 a2ff23951b..865531a718 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 d277ab048a..10c6de626c 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 a763a7c4a7..181a38aa99 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 080fd0ec00..87d41a069f 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 bac9ff5589..f7965b6512 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 e3289b37a1..e8e9bc30e5 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 3c63d34acb..25816b51c7 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 b7ddf906b2..65af1e1311 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 cd6aff51bf..d99f93ddc2 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 b2d0497406..27abfa73b8 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 a20c460349..22e2a33cee 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 ff0a61e794..48d58fe758 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 ec1189c3ea..c136846e14 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 e139cddda7..521c900ec8 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}