)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
- usOnce, eqUsage, seqType, splitTyConApp_maybe )
+ seqType, splitTyConApp_maybe )
import IdInfo
idLBVarInfo id = lbvarInfo (idInfo id)
isOneShotLambda :: Id -> Bool
-isOneShotLambda id = analysis
- where analysis = case idLBVarInfo id of
- LBVarInfo u | u `eqUsage` usOnce -> True
- other -> False
+isOneShotLambda id = case idLBVarInfo id of
+ IsOneShotLambda -> True
+ NoLBVarInfo -> False
setOneShotLambda :: Id -> Id
-setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
clearOneShotLambda :: Id -> Id
clearOneShotLambda id
import CoreSyn
-import Type ( Type, usOnce, eqUsage )
+import Type ( Type )
import PrimOp ( PrimOp )
import NameEnv ( NameEnv, lookupNameEnv )
import Name ( Name )
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
-import Type ( usOnce )
import Demand hiding( Demand, seqDemand )
import qualified Demand
import NewDemand
%************************************************************************
If the @Id@ is a lambda-bound variable then it may have lambda-bound
-var info. The usage analysis (UsageSP) detects whether the lambda
-binding this var is a ``one-shot'' lambda; that is, whether it is
-applied at most once.
+var info. Sometimes we know whether the lambda binding this var is a
+``one-shot'' lambda; that is, whether it is applied at most once.
This information may be useful in optimisation, as computations may
safely be floated inside such a lambda without risk of duplicating
work.
\begin{code}
-data LBVarInfo
- = NoLBVarInfo
-
- | LBVarInfo Type -- The lambda that binds this Id has this usage
- -- annotation (i.e., if ==usOnce, then the
- -- lambda is applied at most once).
- -- The annotation's kind must be `$'
- -- HACK ALERT! placing this info here is a short-term hack,
- -- but it minimises changes to the rest of the compiler.
- -- Hack agreed by SLPJ/KSW 1999-04.
+data LBVarInfo = NoLBVarInfo
+ | IsOneShotLambda -- The lambda is applied at most once).
seqLBVar l = l `seq` ()
\end{code}
\begin{code}
-hasNoLBVarInfo NoLBVarInfo = True
-hasNoLBVarInfo other = False
+hasNoLBVarInfo NoLBVarInfo = True
+hasNoLBVarInfo IsOneShotLambda = False
noLBVarInfo = NoLBVarInfo
--- not safe to print or parse LBVarInfo because it is not really a
--- property of the definition, but a property of the context.
pprLBVarInfo NoLBVarInfo = empty
-pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce
- = ptext SLIT("OneShot")
- | otherwise
- = empty
+pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
instance Outputable LBVarInfo where
ppr = pprLBVarInfo
| otherwise = Just (info `setOccInfo` (if zap_occ then NoOccInfo else old_occ)
`setSpecInfo` substRules subst old_rules
`setWorkerInfo` substWorker subst old_wrkr
- `setLBVarInfo` substLBVar subst old_lbv
`setUnfoldingInfo` noUnfolding)
-- setSpecInfo does a seq
-- setWorkerInfo does a seq
nothing_to_do = not zap_occ &&
isEmptyCoreRules old_rules &&
not (workerExists old_wrkr) &&
- hasNoLBVarInfo old_lbv &&
not (hasUnfolding (unfoldingInfo info))
zap_occ = is_fragile_occ old_occ
old_occ = occInfo info
old_rules = specInfo info
old_wrkr = workerInfo info
- old_lbv = lbvarInfo info
------------------
substIdType :: Subst -> Id -> Id
DoneEx expr -> exprFreeVars expr
DoneTy ty -> tyVarsOfType ty
ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
-
-------------------
-substLBVar subst NoLBVarInfo = NoLBVarInfo
-substLBVar subst (LBVarInfo ty) = ty1 `seq` LBVarInfo ty1
- where
- ty1 = substTy subst ty
\end{code}
HsType(..), HsTyVarBndr(..), HsTyOp(..),
, HsContext, HsPred(..)
, HsTupCon(..), hsTupParens, mkHsTupCon,
- , hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
import PrelNames ( listTyConKey, parrTyConKey,
- usOnceTyConKey, usManyTyConKey, hasKey, unboundKey,
- usOnceTyConName, usManyTyConName )
+ hasKey, unboundKey )
import SrcLoc ( noSrcLoc )
import Util ( eqListBy, lengthIs )
import FiniteMap
-- This keeps interfaces a bit smaller, because there are a lot of arrows
-----------------------
-hsUsOnce, hsUsMany :: HsType RdrName
-hsUsOnce = HsTyVar (mkUnqual tvName FSLIT(".")) -- deep magic
-hsUsMany = HsTyVar (mkUnqual tvName FSLIT("!")) -- deep magic
-
-hsUsOnce_Name, hsUsMany_Name :: HsType Name
-hsUsOnce_Name = HsTyVar usOnceTyConName
-hsUsMany_Name = HsTyVar usManyTyConName
-
------------------------
data HsTupCon = HsTupCon Boxity Arity
instance Eq HsTupCon where
| isTupleTyCon tc = HsTupleTy (HsTupCon (tupleTyConBoxity tc) (tyConArity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
| tc `hasKey` parrTyConKey = HsPArrTy (head tys')
- | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified
- | tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified
| otherwise = generic_case
where
generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
opt_StgDoLetNoEscapes,
opt_UnfoldCasms,
opt_CprOff,
- opt_UsageSPOn,
opt_UnboxStrictFields,
opt_SimplNoPreInlining,
opt_SimplDoEtaReduction,
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
- | CoreDoUSPInf
| CoreDoOldStrictness
| CoreDoGlomBinds
| CoreCSE
| Opt_D_dump_tc
| Opt_D_dump_types
| Opt_D_dump_rules
- | Opt_D_dump_usagesp
| Opt_D_dump_cse
| Opt_D_dump_worker_wrapper
| Opt_D_dump_rn_trace
| Opt_D_dump_minimal_imports
| Opt_DoCoreLinting
| Opt_DoStgLinting
- | Opt_DoUSPLinting
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_WarnDuplicateExports
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape")
opt_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file")
-opt_UsageSPOn = lookUp FSLIT("-fusagesp-on")
opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
"ffoldr-build-on",
"flet-no-escape",
"funfold-casms-in-hi-file",
- "fusagesp-on",
"funbox-strict-fields",
"femit-extern-decls",
"fglobalise-toplev-names",
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.110 2003/01/09 11:39:20 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.111 2003/02/04 15:09:40 simonpj Exp $
--
-- Driver flags
--
, ( "frule-check",
SepArg (\s -> writeIORef v_RuleCheck (Just s)) )
- , ( "fusagesp" , NoArg (do writeIORef v_UsageSPInf True
- add v_Opt_C "-fusagesp-on") )
-
, ( "fexcess-precision" , NoArg (do writeIORef v_Excess_precision True
add v_Opt_C "-fexcess-precision"))
, ( "ddump-tc", NoArg (setDynFlag Opt_D_dump_tc) )
, ( "ddump-types", NoArg (setDynFlag Opt_D_dump_types) )
, ( "ddump-rules", NoArg (setDynFlag Opt_D_dump_rules) )
- , ( "ddump-usagesp", NoArg (setDynFlag Opt_D_dump_usagesp) )
, ( "ddump-cse", NoArg (setDynFlag Opt_D_dump_cse) )
, ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) )
, ( "dshow-passes", NoArg (setVerbosity "2") )
, ( "ddump-vect", NoArg (setDynFlag Opt_D_dump_vect) )
, ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) )
, ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) )
- , ( "dusagesp-lint", NoArg (setDynFlag Opt_DoUSPLinting) )
------ Machine dependant (-m<blah>) stuff ---------------------------
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.89 2002/12/19 18:43:53 wolfgang Exp $
+-- $Id: DriverState.hs,v 1.90 2003/02/04 15:09:40 simonpj Exp $
--
-- Settings for the driver
--
GLOBAL_VAR(v_minus_o2_for_C, False, Bool)
GLOBAL_VAR(v_MaxSimplifierIterations, 4, Int)
GLOBAL_VAR(v_StgStats, False, Bool)
-GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default
GLOBAL_VAR(v_Strictness, True, Bool)
GLOBAL_VAR(v_CSE, True, Bool)
GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String)
buildCoreToDo = do
opt_level <- readIORef v_OptLevel
max_iter <- readIORef v_MaxSimplifierIterations
- usageSP <- readIORef v_UsageSPInf
strictness <- readIORef v_Strictness
cse <- readIORef v_CSE
rule_check <- readIORef v_RuleCheck
],
case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
- -- infer usage information here in case we need it later.
- -- (add more of these where you need them --KSW 1999-04)
- if usageSP then CoreDoUSPInf else CoreDoNothing,
-
CoreDoSimplify (SimplPhase 1) [
-- Need inline-phase2 here so that build/augment get
-- inlined. I found that spectral/hartel/genfft lost some useful
import ParserCoreUtils
import Ratio
import Char
+import Numeric( readFloat )
isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
isKeywordChar c = isAlpha c || (c == '_')
lexer :: (Token -> P a) -> P a
-lexer cont [] = cont TKEOF []
-lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
+lexer cont [] = cont TKEOF []
+lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
lexer cont ('-':'>':cs) = cont TKrarrow cs
+
lexer cont (c:cs)
- | isSpace c = lexer cont cs
+ | isSpace c = lexer cont cs
| isLower c || (c == '_') = lexName cont TKname (c:cs)
- | isUpper c = lexName cont TKcname (c:cs)
+ | isUpper c = lexName cont TKcname (c:cs)
| isDigit c || (c == '-') = lexNum cont (c:cs)
-lexer cont ('%':cs) = lexKeyword cont cs
-lexer cont ('\'':cs) = lexChar cont cs
-lexer cont ('\"':cs) = lexString [] cont cs
-lexer cont ('#':cs) = cont TKhash cs
-lexer cont ('(':cs) = cont TKoparen cs
-lexer cont (')':cs) = cont TKcparen cs
-lexer cont ('{':cs) = cont TKobrace cs
-lexer cont ('}':cs) = cont TKcbrace cs
-lexer cont ('=':cs) = cont TKeq cs
+
+lexer cont ('%':cs) = lexKeyword cont cs
+lexer cont ('\'':cs) = lexChar cont cs
+lexer cont ('\"':cs) = lexString [] cont cs
+lexer cont ('#':cs) = cont TKhash cs
+lexer cont ('(':cs) = cont TKoparen cs
+lexer cont (')':cs) = cont TKcparen cs
+lexer cont ('{':cs) = cont TKobrace cs
+lexer cont ('}':cs) = cont TKcbrace cs
+lexer cont ('=':cs) = cont TKeq cs
lexer cont (':':':':cs) = cont TKcoloncolon cs
-lexer cont ('*':cs) = cont TKstar cs
-lexer cont ('.':cs) = cont TKdot cs
-lexer cont ('\\':cs) = cont TKlambda cs
-lexer cont ('@':cs) = cont TKat cs
-lexer cont ('?':cs) = cont TKquestion cs
-lexer cont (';':cs) = cont TKsemicolon cs
-lexer cont (c:cs) = failP "invalid character" [c]
+lexer cont ('*':cs) = cont TKstar cs
+lexer cont ('.':cs) = cont TKdot cs
+lexer cont ('\\':cs) = cont TKlambda cs
+lexer cont ('@':cs) = cont TKat cs
+lexer cont ('?':cs) = cont TKquestion cs
+lexer cont (';':cs) = cont TKsemicolon cs
+lexer cont (c:cs) = failP "invalid character" [c]
+
+
lexChar cont ('\\':'x':h1:h0:'\'':cs)
| isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
-lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
-lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
-lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
+lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
+lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
+lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
lexChar cont (c:'\'':cs) = cont (TKchar c) cs
+
lexString s cont ('\\':'x':h1:h0:cs)
| isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
-hexToChar h1 h0 =
- chr(
- (digitToInt h1) * 16 +
- (digitToInt h0))
+hexToChar h1 h0 = chr (digitToInt h1 * 16 + digitToInt h0)
lexNum cont cs =
case cs of
- ('-':cs) -> f (-1) cs
- _ -> f 1 cs
+ ('-':cs) -> f (-1) cs
+ _ -> f 1 cs
where f sgn cs =
case span isDigit cs of
- (digits,'.':c:rest) | isDigit c ->
- cont (TKrational (numer % denom)) rest'
- where (fpart,rest') = span isDigit (c:rest)
- denom = 10^(length fpart)
- numer = sgn * ((read digits) * denom + (read fpart))
+ (digits,'.':c:rest)
+ | isDigit c -> cont (TKrational r) rest'
+ where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest))
+ -- When reading a floating-point number, which is
+ -- a bit comlicated, use the Haskell 98 library function
(digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
lexName cont cstr cs = cont (cstr name) rest
runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey
-- Stuff from GHC.Prim
-usOnceTyConName = kindQual FSLIT(".") usOnceTyConKey
-usManyTyConName = kindQual FSLIT("!") usManyTyConKey
superKindName = kindQual FSLIT("KX") kindConKey
superBoxityName = kindQual FSLIT("BX") boxityConKey
liftedConName = kindQual FSLIT("*") liftedConKey
unliftedConName = kindQual FSLIT("#") unliftedConKey
openKindConName = kindQual FSLIT("?") anyBoxConKey
-usageKindConName = kindQual FSLIT("$") usageConKey
typeConName = kindQual FSLIT("Type") typeConKey
funTyConName = tcQual gHC_PRIM_Name FSLIT("(->)") funTyConKey
ptrTyConKey = mkPreludeTyConUnique 74
funPtrTyConKey = mkPreludeTyConUnique 75
--- Usage type constructors
-usageConKey = mkPreludeTyConUnique 76
-usOnceTyConKey = mkPreludeTyConUnique 77
-usManyTyConKey = mkPreludeTyConUnique 78
-
-- Generic Type Constructors
crossTyConKey = mkPreludeTyConUnique 79
plusTyConKey = mkPreludeTyConUnique 80
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecConstr ( specConstrProgram)
-import UsageSPInf ( doUsageSPInf )
import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
#ifdef OLD_STRICTNESS
#endif
doCorePass dfs rb us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs rb us binds CoreDoUSPInf
- = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
doCorePass dfs rb us binds CoreDoGlomBinds
= noStats dfs (glomBinds dfs binds)
doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
- typeKind, eqKind, eqUsage,
+ typeKind, eqKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta
) where
tidyTopType, tidyType, tidyPred, tidyTypes,
tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar,
- tidyOpenTyVars, eqKind, eqUsage,
+ tidyOpenTyVars, eqKind,
hasMoreBoxityInfo, liftedBoxity,
superBoxity, typeKind, superKind, repType
)
where sig_ty is the type given by the method's signature, and thus in general
is a ForallTy. At the point that splitMethodTy is called, it is expected
that the outer Forall has already been stripped off. splitMethodTy then
-returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or
-Usages stripped off.
+returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
\begin{code}
tcSplitMethodTy :: Type -> (PredType, Type)
other -> maybeParen ctxt_prec tYCON_PREC
(ppr tycon <+> ppr_ty tYCON_PREC ty)
- -- USAGE CASE
- | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey),
- null tys
- = -- For usages (! and .), always print bare OccName, without pkg/mod/uniq
- ppr (getOccName (tyConName tycon))
-
-- TUPLE CASE (boxed and unboxed)
| isTupleTyCon tycon,
tys `lengthIs` tyConArity tycon -- No magic if partially applied
isTypeKind, isAnyTypeKind,
funTyCon,
- usageKindCon, -- :: KX
- usageTypeKind, -- :: KX
- usOnceTyCon, usManyTyCon, -- :: $
- usOnce, usMany, -- :: $
-
-- exports from this module:
hasMoreBoxityInfo, defaultKind,
tidyTopType, tidyPred,
-- Comparison
- eqType, eqKind, eqUsage,
+ eqType, eqKind,
-- Seq
seqType, seqTypes
\begin{code}
eqType t1 t2 = eq_ty emptyVarEnv t1 t2
eqKind = eqType -- No worries about looking
-eqUsage = eqType -- through source types for these two
-- Look through Notes
eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
- usageKindCon, -- :: KX
- usageTypeKind, -- :: KX
- usOnceTyCon, usManyTyCon, -- :: $
- usOnce, usMany, -- :: $
-
funTyCon
) where
-- others
import PrelNames ( superKindName, superBoxityName, liftedConName,
unliftedConName, typeConName, openKindConName,
- usageKindConName, usOnceTyConName, usManyTyConName,
funTyConName
)
\end{code}
| Type liftedness -- (Type *) is printed as just *
-- (Type #) is printed as just #
- | UsageKind -- Printed '$'; used for usage annotations
-
| OpenKind -- Can be lifted or unlifted
-- Printed '?'
\end{code}
------------------------------------------
-Define kinds: Type, Type *, Type #, OpenKind, and UsageKind
+Define kinds: Type, Type *, Type #, OpenKind
\begin{code}
typeCon :: KindCon -- :: BX -> KX
openKindCon = mkKindCon openKindConName superKind
openTypeKind = TyConApp openKindCon []
-
-usageKindCon = mkKindCon usageKindConName superKind
-usageTypeKind = TyConApp usageKindCon []
\end{code}
------------------------------------------
instance Binary Kind where
put_ bh k@(TyConApp tc [])
| tc == openKindCon = putByte bh 0
- | tc == usageKindCon = putByte bh 1
put_ bh k@(TyConApp tc [TyConApp bc _])
| tc == typeCon && bc == liftedBoxityCon = putByte bh 2
| tc == typeCon && bc == unliftedBoxityCon = putByte bh 3
b <- getByte bh
case b of
0 -> return openTypeKind
- 1 -> return usageTypeKind
2 -> return liftedTypeKind
3 -> return unliftedTypeKind
_ -> do f <- get bh; a <- get bh; return (FunTy f a)
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
\end{code}
-------------------------------------------
-Usage tycons @.@ and @!@
-
-The usage tycons are of kind usageTypeKind (`$'). The types contain
-no values, and are used purely for usage annotation.
-
-\begin{code}
-usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind
-usOnce = TyConApp usOnceTyCon []
-
-usManyTyCon = mkKindCon usManyTyConName usageTypeKind
-usMany = TyConApp usManyTyCon []
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[UConSet]{UsageSP constraint solver}
-
-This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
-February 1998 .. April 1999.
-
-Keith Wansbrough 1998-02-16..1999-04-29
-
-\begin{code}
-module UConSet ( {- SEE BELOW: -- KSW 2000-10-13
- UConSet,
- emptyUConSet,
- eqManyUConSet,
- eqUConSet,
- leqUConSet,
- unionUCS,
- unionUCSs,
- solveUCS, -}
- ) where
-
-#include "HsVersions.h"
-
-import VarEnv
-import Bag ( Bag, unitBag, emptyBag, unionBags, foldlBag, bagToList )
-import Outputable
-import PprType
-
-{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
-
- This monomorphic version of the analysis is outdated. I'm
- currently ripping out the old one and inserting the new one. For
- now, I'm simply commenting out this entire file.
-
-\end{code}
-
-======================================================================
-
-The data type:
-~~~~~~~~~~~~~~
-
-First, individual constraints on particular variables. This is
-private to the implementation.
-
-\begin{code}
-data UCon = UCEq UVar UVar -- j = k (equivalence)
- | UCBound [UVar] UVar [UVar] -- {..} <= j <= {..}
- | UCUsOnce UVar -- j = 1
- | UCUsMany UVar -- j = omega
-\end{code}
-
-Next, the public (but abstract) data type for a usage constraint set:
-either a bag of mappings from @UVar@ to @UCon@, or an error message
-for an inconsistent constraint set.
-
-\begin{code}
-data UConSet = UConSet (Bag (VarEnv UCon))
- | UConFail SDoc
-\end{code}
-
-The idea is that the @VarEnv@s (which will eventually be merged into a
-single @VarEnv@) are union-find data structures: a variable is either
-equal to another variable, or it is bounded or has a value. The
-equalities form a forest pointing to a root node for each equality
-class, on which is found the bound or value for that class.
-
-The @Bag@ enables two-phase operation: we merely collect constraints
-in the first phase, an donly union them at solution time. This gives
-a much more efficient algorithm, as we make only a single pass over
-the constraints.
-
-Note that the absence of a variable from the @VarEnv@ is exactly
-equivalent to it being mapped to @UCBound [] _ []@.
-
-
-The interface:
-~~~~~~~~~~~~~~
-
-@emptyUConSet@ gives an empty constraint set.
-@eqManyUConSet@ constrains an annotation to be Many.
-@eqUConSet@ constrains two annotations to be equal.
-@leqUConSet@ constrains one annotation to be less than or equal to
-another (with Once < Many).
-
-\begin{code}
-mkUCS = UConSet . unitBag -- helper function not exported
-
-emptyUConSet :: UConSet
-emptyUConSet = UConSet emptyBag
-
-eqManyUConSet :: UsageAnn -> UConSet
-
-eqManyUConSet UsOnce = UConFail (text "Once /= Many")
-eqManyUConSet UsMany = emptyUConSet
-eqManyUConSet (UsVar uv) = mkUCS $ unitVarEnv uv (UCUsMany uv)
-
-eqUConSet :: UsageAnn -> UsageAnn -> UConSet
-
-eqUConSet UsOnce UsOnce = emptyUConSet
-eqUConSet UsOnce (UsVar uv) = mkUCS $ unitVarEnv uv (UCUsOnce uv)
-eqUConSet UsMany UsMany = emptyUConSet
-eqUConSet UsMany (UsVar uv) = mkUCS $ unitVarEnv uv (UCUsMany uv)
-eqUConSet (UsVar uv) UsOnce = mkUCS $ unitVarEnv uv (UCUsOnce uv)
-eqUConSet (UsVar uv) UsMany = mkUCS $ unitVarEnv uv (UCUsMany uv)
-eqUConSet (UsVar uv) (UsVar uv') = if uv==uv'
- then emptyUConSet
- else mkUCS $ unitVarEnv uv (UCEq uv uv')
-eqUConSet UsMany UsOnce = UConFail (text "Many /= Once")
-eqUConSet UsOnce UsMany = UConFail (text "Once /= Many")
-
-leqUConSet :: UsageAnn -> UsageAnn -> UConSet
-
-leqUConSet UsOnce _ = emptyUConSet
-leqUConSet _ UsMany = emptyUConSet
-leqUConSet UsMany UsOnce = UConFail (text "Many /<= Once")
-leqUConSet UsMany (UsVar uv) = mkUCS $ unitVarEnv uv (UCUsMany uv)
-leqUConSet (UsVar uv) UsOnce = mkUCS $ unitVarEnv uv (UCUsOnce uv)
-leqUConSet (UsVar uv) (UsVar uv') = mkUCS $ mkVarEnv [(uv, UCBound [] uv [uv']),
- (uv',UCBound [uv] uv' [] )]
-\end{code}
-
-@unionUCS@ forms the union of two @UConSet@s.
-@unionUCSs@ forms the `big union' of a list of @UConSet@s.
-
-\begin{code}
-unionUCS :: UConSet -> UConSet -> UConSet
-
-unionUCS (UConSet b1) (UConSet b2) = UConSet (b1 `unionBags` b2)
-unionUCS ucs@(UConFail _) _ = ucs -- favour first error
-unionUCS (UConSet _) ucs@(UConFail _) = ucs
-
-unionUCSs :: [UConSet] -> UConSet
-
-unionUCSs ucss = foldl unionUCS emptyUConSet ucss
-\end{code}
-
-
-@solveUCS@ finds the minimal solution to the constraint set, returning
-it as @Just@ a substitution function taking usage variables to usage
-annotations (@UsOnce@ or @UsMany@). If this is not possible (for an
-inconsistent constraint set), @solveUCS@ returns @Nothing@.
-
-The minimal solution is found by simply reading off the known
-variables, and for unknown ones substituting @UsOnce@.
-
-\begin{code}
-solveUCS :: UConSet -> Maybe (UVar -> UsageAnn)
-
-solveUCS (UConSet css)
- = case foldlBag (\cs1 jcs2 -> foldVarEnv addUCS cs1 jcs2)
- (Left emptyVarEnv)
- css of
- Left cs -> let cs' = mapVarEnv conToSub cs
- sub uv = case lookupVarEnv cs' uv of
- Just u -> u
- Nothing -> UsOnce
- conToSub (UCEq _ uv') = case lookupVarEnv cs uv' of
- Nothing -> UsOnce
- Just con' -> conToSub con'
- conToSub (UCUsOnce _ ) = UsOnce
- conToSub (UCUsMany _ ) = UsMany
- conToSub (UCBound _ _ _ ) = UsOnce
- in Just sub
- Right err -> solveUCS (UConFail err)
-
-solveUCS (UConFail why) =
-#ifdef DEBUG
- pprTrace "UConFail:" why $
-#endif
- Nothing
-\end{code}
-
-======================================================================
-
-The internals:
-~~~~~~~~~~~~~~
-
-In the internals, we use the @VarEnv UCon@ explicitly, or occasionally
-@Either (VarEnv UCon) SDoc@. In other words, the @Bag@ is no longer
-used.
-
-@findUCon@ finds the root of an equivalence class.
-@changeUConUVar@ copies a constraint, but changes the variable constrained.
-
-\begin{code}
-findUCon :: VarEnv UCon -> UVar -> UVar
-
-findUCon cs uv
- = case lookupVarEnv cs uv of
- Just (UCEq _ uv') -> findUCon cs uv'
- Just _ -> uv
- Nothing -> uv
-
-changeUConUVar :: UCon -> UVar -> UCon
-
-changeUConUVar (UCEq _ v ) uv' = (UCEq uv' v )
-changeUConUVar (UCBound us _ vs) uv' = (UCBound us uv' vs)
-changeUConUVar (UCUsOnce _ ) uv' = (UCUsOnce uv' )
-changeUConUVar (UCUsMany _ ) uv' = (UCUsMany uv' )
-\end{code}
-
-@mergeUVars@ tests to see if a set of @UVar@s can be constrained. If
-they can, it returns the set of root @UVar@s represented (with no
-duplicates); if they can't, it returns @Nothing@.
-
-\begin{code}
-mergeUVars :: VarEnv UCon -- current constraint set
- -> Bool -- True/False = try to constrain to Many/Once
- -> [UVar] -- list of UVars to constrain
- -> Maybe [UVar] -- Just [root uvars to force], or Nothing if conflict
-
-mergeUVars cs isMany vs = foldl muv (Just []) vs
- where
- muv :: Maybe [UVar] -> UVar -> Maybe [UVar]
- muv Nothing _
- = Nothing
- muv jvs@(Just vs) v
- = let rv = findUCon cs v
- in if elem rv vs
- then
- jvs
- else
- case lookupVarEnv cs rv of -- never UCEq
- Nothing -> Just (rv:vs)
- Just (UCBound _ _ _) -> Just (rv:vs)
- Just (UCUsOnce _) -> if isMany then Nothing else jvs
- Just (UCUsMany _) -> if isMany then jvs else Nothing
-\end{code}
-
-@addUCS@ adds an individual @UCon@ on a @UVar@ to a @UConSet@. This
-is the core of the algorithm. As such, it could probably use some
-optimising.
-
-\begin{code}
-addUCS :: UCon -- constraint to add
- -> Either (VarEnv UCon) SDoc -- old constraint set or error
- -> Either (VarEnv UCon) SDoc -- new constraint set or error
-
-addUCS _ jcs@(Right _) = jcs -- propagate errors
-
-addUCS (UCEq uv1 uv2) jcs@(Left cs)
- = let ruv1 = findUCon cs uv1
- ruv2 = findUCon cs uv2
- in if ruv1==ruv2
- then jcs -- no change if already equal
- else let cs' = Left $ extendVarEnv cs ruv1 (UCEq ruv1 ruv2) -- merge trees
- in case lookupVarEnv cs ruv1 of
- Just uc'
- -> addUCS (changeUConUVar uc' ruv2) cs' -- merge old constraints
- Nothing
- -> cs'
-
-addUCS (UCBound us uv1 vs) jcs@(Left cs)
- = let ruv1 = findUCon cs uv1
- in case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of -- never UCEq
- UCBound us' _ vs'
- -> case (mergeUVars cs False (us'++us),
- mergeUVars cs True (vs'++vs)) of
- (Just us'',Just vs'') -- update
- -> Left $ extendVarEnv cs ruv1 (UCBound us'' ruv1 vs'')
- (Nothing, Just vs'') -- set
- -> addUCS (UCUsMany ruv1)
- (forceUVars UCUsMany vs'' jcs)
- (Just us'',Nothing) -- set
- -> addUCS (UCUsOnce ruv1)
- (forceUVars UCUsOnce us'' jcs)
- (Nothing, Nothing) -- fail
- -> Right (text "union failed[B] at" <+> ppr uv1)
- UCUsOnce _
- -> forceUVars UCUsOnce us jcs
- UCUsMany _
- -> forceUVars UCUsMany vs jcs
-
-addUCS (UCUsOnce uv1) jcs@(Left cs)
- = let ruv1 = findUCon cs uv1
- in case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of -- never UCEq
- UCBound us _ vs
- -> forceUVars UCUsOnce us (Left $ extendVarEnv cs ruv1 (UCUsOnce ruv1))
- UCUsOnce _
- -> jcs
- UCUsMany _
- -> Right (text "union failed[O] at" <+> ppr uv1)
-
-addUCS (UCUsMany uv1) jcs@(Left cs)
- = let ruv1 = findUCon cs uv1
- in case lookupWithDefaultVarEnv cs (UCBound [] ruv1 []) ruv1 of -- never UCEq
- UCBound us _ vs
- -> forceUVars UCUsMany vs (Left $ extendVarEnv cs ruv1 (UCUsMany ruv1))
- UCUsOnce _
- -> Right (text "union failed[M] at" <+> ppr uv1)
- UCUsMany _
- -> jcs
-
--- helper function forcing a set of UVars to either Once or Many:
-forceUVars :: (UVar -> UCon)
- -> [UVar]
- -> Either (VarEnv UCon) SDoc
- -> Either (VarEnv UCon) SDoc
-forceUVars uc uvs cs0 = foldl (\cs uv -> addUCS (uc uv) cs) cs0 uvs
-\end{code}
-
-======================================================================
-
-Pretty-printing:
-~~~~~~~~~~~~~~~~
-
-\begin{code}
--- Printing a usage constraint.
-
-pprintUCon :: VarEnv UCon -> UCon -> SDoc
-
-pprintUCon fm (UCEq uv1 uv2)
- = ppr uv1 <+> text "=" <+> ppr uv2 <> text ":"
- <+> let uv2' = findUCon fm uv2
- in case lookupVarEnv fm uv2' of
- Just uc -> pprintUCon fm uc
- Nothing -> text "unconstrained"
-
-pprintUCon fm (UCBound us uv vs)
- = lbrace <> hcat (punctuate comma (map ppr us)) <> rbrace
- <+> text "<=" <+> ppr uv <+> text "<="
- <+> lbrace <> hcat (punctuate comma (map ppr vs)) <> rbrace
-
-pprintUCon fm (UCUsOnce uv)
- = ppr uv <+> text "=" <+> ppr UsOnce
-
-pprintUCon fm (UCUsMany uv)
- = ppr uv <+> text "=" <+> ppr UsMany
-
--- Printing a usage constraint set.
-
-instance Outputable UConSet where
- ppr (UConSet bfm)
- = text "UConSet:" <+> lbrace
- $$ vcat (map (\fm -> nest 2 (vcat (map (pprintUCon fm) (rngVarEnv fm))))
- (bagToList bfm))
- $$ rbrace
-
- ppr (UConFail d)
- = hang (text "UConSet inconsistent:")
- 4 d
-
-END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
-\end{code}
-
-======================================================================
-
-EOF
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[UsageSPInf]{UsageSP Inference Engine}
-
-This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
-September 1998 .. May 1999.
-
-Keith Wansbrough 1998-09-04..1999-07-06
-
-\begin{code}
-module UsageSPInf ( doUsageSPInf ) where
-
-#include "HsVersions.h"
-
-import UsageSPUtils
-import UsageSPLint
-import UConSet
-
-import CoreSyn
-import Rules ( RuleBase )
-import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( applyTy, applyTys,
- splitFunTy_maybe, splitFunTys, splitTyConApp,
- mkFunTy, mkForAllTy )
-import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
-import Literal ( Literal(..), literalType )
-import Var ( Var, varType, setVarType, modifyIdInfo )
-import IdInfo ( setLBVarInfo, LBVarInfo(..) )
-import Id ( isExportedId )
-import VarEnv
-import VarSet
-import UniqSupply ( UniqSupply, UniqSM,
- initUs, splitUniqSupply )
-import Util ( lengthExceeds )
-import Outputable
-import Maybes ( expectJust )
-import List ( unzip4 )
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn )
-import CoreLint ( showPass, endPass )
-import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn )
-import PprCore ( pprCoreBindings )
-\end{code}
-
-======================================================================
-
--- **! wasn't I going to do something about not requiring annotations
--- to be correct on unpointed types and/or those without haskell pointers
--- inside?
-
-The whole inference
-~~~~~~~~~~~~~~~~~~~
-
-For full details, see _Once Upon a Polymorphic Type_, University of
-Glasgow Department of Computing Science Technical Report TR-1998-19,
-December 1998, or the summary in POPL'99.
-
-[** NEW VERSION NOW IMPLEMENTED; different from the papers
- above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
- University of Cambridge PhD thesis, c. Sep 2000 **]
-
-
-Inference is performed as follows:
-
- 1. Remove all manipulable[*] annotations.
-
- 2. Walk over the resulting term adding fresh UVar annotations,
- applying the type rules and collecting the constraints.
-
- 3. Find the solution to the constraints and apply the substitution
- to the annotations, leaving a @UVar@-free term.
-
-[*] A manipulable annotation is one derived from the current source
-module, as opposed to one derived from an import, which we are clearly
-not allowed to alter.
-
-As in the paper, a ``tau-type'' is a type that does *not* have an
-annotation on top (although it may have some inside), and a
-``sigma-type'' is one that does (i.e., is a tau-type with an
-annotation added). Also, a ``rho-type'' is one that may have initial
-``\/u.''s. This conflicts with the totally unrelated usage of these
-terms in the remainder of GHC. Caveat lector! KSW 1999-07.
-
-
-The inference is done over a set of @CoreBind@s, and inside the IO
-monad.
-
-\begin{code}
-doUsageSPInf :: DynFlags
- -> UniqSupply
- -> [CoreBind]
- -> IO [CoreBind]
-
-doUsageSPInf dflags us binds
- | not opt_UsageSPOn
- = do { printDump (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
- return binds
- }
-
-{- ENTIRE PASS COMMENTED OUT FOR NOW -- KSW 2000-10-13
-
- This monomorphic version of the analysis is outdated. I'm
- currently ripping out the old one and inserting the new one. For
- now, I'm simply commenting out this entire pass.
-
-
- | otherwise
- = do
- let binds1 = doUnAnnotBinds binds
-
- showPass dflags "UsageSPInf"
-
- dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
- pprCoreBindings binds1
-
- let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
-
- dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf annot'd" $
- pprCoreBindings binds2
-
- let ms = solveUCS ucs
- s = case ms of
- Just s -> s
- Nothing -> panic "doUsageSPInf: insol. conset!"
- binds3 = appUSubstBinds s binds2
-
- doIfSet_dyn dflags Opt_DoUSPLinting $
- do doLintUSPAnnotsBinds binds3 -- lint check 1
- doLintUSPConstBinds binds3 -- lint check 2 (force solution)
- doCheckIfWorseUSP binds binds3 -- check for worsening of usages
-
- endPass dflags "UsageSPInf" (dopt Opt_D_dump_usagesp dflags) binds3
-
- return binds3
-\end{code}
-
-======================================================================
-
-Inferring an expression
-~~~~~~~~~~~~~~~~~~~~~~~
-
-Inference takes an annotated (rho-typed) environment and an expression
-unannotated except for variables not appearing in the environment. It
-returns an annotated expression, a type, a constraint set, and a
-multiset of free variables. It is in the unique supply monad, which
-supplies fresh uvars for annotation.
-
-We conflate usage metavariables and usage variables; the latter are
-distinguished by falling within the scope of a usage binder.
-
-\begin{code}
-usgInfBinds :: VarEnv Var -- incoming environment (usu. empty)
- -> [CoreBind] -- CoreBinds in dependency order
- -> UniqSMM ([CoreBind], -- annotated CoreBinds
- UConSet, -- constraint set
- VarMultiset) -- usage of environment vars
-
-usgInfBinds ve []
- = return ([],
- emptyUConSet,
- emptyMS)
-
-usgInfBinds ve (b0:b0s)
--- (this clause is almost the same as the Let clause)
- = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind ve b0
- (b2s,h2,f2) <- usgInfBinds ve1 b0s
- let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
- return (b1:b2s,
- unionUCSs [h1,h2,h3],
- fa1 `plusMS` (f2 `delsFromMS` v1s))
-
-
-usgInfBind :: VarEnv Var
- -> CoreBind -- CoreBind to infer for
- -> UniqSMM ([Var], -- variables bound
- VarEnv Var, -- extended VarEnv
- CoreBind, -- annotated CoreBind
- UConSet, -- constraints generated by this CoreBind
- VarMultiset, -- this bd's use of vars bound in this bd
- -- (could be anything for other vars)
- VarMultiset) -- this bd's use of other vars
-
-usgInfBind ve (NonRec v1 e1)
- = do (v1',y1u) <- annotVar v1
- (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
- let h3 = usgSubTy y2u y1u
- h4 = h2 `unionUCS` h3
- (y4r,h4') = usgClos ve y2u h4
- v1'' = setVarType v1 y4r
- h5 = if isExportedId v1 then pessimise y4r else emptyUConSet
- return ([v1''],
- extendVarEnv ve v1 v1'',
- NonRec v1'' e2,
- h4' `unionUCS` h5,
- emptyMS,
- f2)
-
-usgInfBind ve (Rec ves)
- = do let (v1s,e1s) = unzip ves
- vy1s' <- mapM annotVar v1s
- let (v1s',y1us) = unzip vy1s'
- ve' = ve `plusVarEnv` (zipVarEnv v1s v1s')
- eyhf2s <- mapM (usgInfCE ve') e1s
- let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
- h3s = zipWith usgSubTy y2us y1us
- h4s = zipWith unionUCS h2s h3s
- yh4s = zipWith (usgClos ve) y2us h4s
- (y4rs,h4s') = unzip yh4s
- v1s'' = zipWith setVarType v1s y4rs
- f5 = foldl plusMS emptyMS f2s
- h6s = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
- v1s y4rs
- return (v1s'',
- ve `plusVarEnv` (zipVarEnv v1s v1s''),
- Rec (zip v1s'' e2s),
- unionUCSs (h4s' ++ h6s),
- f5,
- f5 `delsFromMS` v1s') -- we take pains that v1'==v1'' etc
-
-
-usgInfCE :: VarEnv Var -- unannotated -> annotated vars
- -> CoreExpr -- expression to annotate / infer
- -> UniqSMM (CoreExpr, -- annotated expression (e)
- Type, -- (sigma) type of expression (y)(u=sigma)(r=rho)
- UConSet, -- set of constraints arising (h)
- VarMultiset) -- variable occurrences (f)
-
-usgInfCE ve e0@(Var v) | isTyVar v
- = panic "usgInfCE: unexpected TyVar"
- | otherwise
- = do v' <- instVar (lookupVar ve v)
- return $ ASSERT( isUsgTy (varType v' {-'cpp-}) )
- (Var v',
- varType v',
- emptyUConSet,
- unitMS v')
-
-usgInfCE ve e0@(Lit lit)
- = do u1 <- newVarUSMM (Left e0)
- return (e0,
- mkUsgTy u1 (literalType lit),
- emptyUConSet,
- emptyMS)
-
-{- ------------------------------------
- No Con form now; we rely on usage information in the constructor itself
-
-usgInfCE ve e0@(Con con args)
- = -- constant or primop. guaranteed saturated.
- do let (ey1s,e1s) = span isTypeArg args
- y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s -- univ. + exist.
- (y2us,y2u) <- case con of
- DataCon c -> do u2 <- newVarUSMM (Left e0)
- return $ dataConTys c u2 y1s
- -- y1s is exdicts + args
- PrimOp p -> return $ primOpUsgTys p y1s
- otherwise -> panic "usgInfCE: unrecognised Con"
- eyhf3s <- mapM (usgInfCE ve) e1s
- let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
- h4s = zipWith usgSubTy y3us y2us
- return $ ASSERT( isUsgTy y2u )
- (Con con (map Type y1s ++ e3s),
- y2u,
- unionUCSs (h3s ++ h4s),
- foldl plusMS emptyMS f3s)
-
- whered ataConTys c u y1s
- -- compute argtys of a datacon
- = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced
- (y2us,y2u) = splitFunTys (applyTys cTy y1s)
- -- safe 'cos a DataCon always returns a value of type (TyCon tys),
- -- not an arrow type.
- reUsg = mkUsgTy u . unUsgTy
- in (map reUsg y2us, reUsg y2u)
--------------------------------------------- -}
-
-
-usgInfCE ve e0@(App ea (Type yb))
- = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
- let (u1,ya1) = splitUsgTy ya1u
- yb1 <- annotTyN (Left e0) yb
- return (App ea1 (Type yb1),
- mkUsgTy u1 (applyTy ya1 yb1),
- ha1,
- fa1)
-
-usgInfCE ve (App ea eb)
- = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
- let ( u1,ya1) = splitUsgTy ya1u
- (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
- (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
- let h4 = usgSubTy yb1u y2u
- return $ ASSERT( isUsgTy y3u )
- (App ea1 eb1,
- y3u,
- unionUCSs [ha1,hb1,h4],
- fa1 `plusMS` fb1)
-
-usgInfCE ve e0@(Lam v0 e) | isTyVar v0
- = do (e1,y1u,h1,f1) <- usgInfCE ve e
- let (u1,y1) = splitUsgTy y1u
- return (Lam v0 e1,
- mkUsgTy u1 (mkForAllTy v0 y1),
- h1,
- f1)
-
- -- [OLD COMMENT:]
- -- if used for checking also, may need to extend this case to
- -- look in lbvarInfo instead.
- | otherwise
- = do u1 <- newVarUSMM (Left e0)
- (v1,y1u) <- annotVar v0
- (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
- let h3 = occChkUConSet v1 f2
- f2' = f2 `delFromMS` v1
- h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
- : hs)) -- in reverse order!
- []
- f2'
- return (Note (TermUsg u1) (Lam v1 e2), -- add annot for lbVarInfo computation
- mkUsgTy u1 (mkFunTy y1u y2u),
- unionUCSs (h2:h3:h4s),
- f2')
-
-usgInfCE ve (Let b0s e0)
- = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
- (e2,y2u,h2,f2) <- usgInfCE ve1 e0
- let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
- return $ ASSERT( isUsgTy y2u )
- (Let b1s e2,
- y2u,
- unionUCSs [h1,h2,h3],
- fa1 `plusMS` (f2 `delsFromMS` v1s))
-
-usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
--- pure strict let, no selection (could be at polymorphic or function type)
- = do (v1,y1u) <- annotVar v0
- (e2,y2u,h2,f2) <- usgInfCE ve e0
- (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
- let h4 = usgEqTy y2u y1u -- **! why not subty?
- h5 = occChkUConSet v1 f3
- return $ ASSERT( isUsgTy y3u )
- (Case e2 v1 [(DEFAULT,[],e3)],
- y3u,
- unionUCSs [h2,h3,h4,h5],
- f2 `plusMS` (f3 `delFromMS` v1))
-
-usgInfCE ve e0@(Case e1 v1 alts)
--- general case (tycon of scrutinee must be known)
--- (assumes well-typed already; so doesn't check constructor)
- = do (v2,y1u) <- annotVar v1
- (e2,y2u,h2,f2) <- usgInfCE ve e1
- let h3 = usgEqTy y2u y1u -- **! why not subty?
- (u2,y2) = splitUsgTy y2u
- (tc,y2s) = splitTyConApp y2
- (cs,v1ss,es) = unzip3 alts
- v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
- v1ss
- ve3 = extendVarEnv ve v1 v2
- eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
- (zip3 v1ss v2ss es)
- let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
- y5u <- annotTy (Left e0) (unannotTy (head y4us))
- let h5s = zipWith usgSubTy y4us (repeat y5u)
- h6s = zipWith occChksUConSet v2ss f4s
- f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
- h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
- return $ ASSERT( isUsgTy y5u )
- (Case e2 v2 (zip3 cs v2ss e4s),
- y5u,
- unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
- f2 `plusMS` (f4 `delFromMS` v2))
-
-usgInfCE ve e0@(Note note ea)
- = do (e1,y1u,h1,f1) <- usgInfCE ve ea
- case note of
- Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
- ya3 = annotManyN ya -- really nasty type
- h3 = usgEqTy y1 ya3 -- messy but OK
- yb3 <- annotTyN (Left e0) yb
- -- What this says is that a Coerce does the most general possible
- -- annotation to what's inside it (nasty, nasty), because no information
- -- can pass through a Coerce. It of course simply ignores the info
- -- that filters down through into ty1, because it can do nothing with it.
- -- It does still pass through the topmost usage annotation, though.
- return (Note (Coerce yb3 ya3) e1,
- mkUsgTy u1 yb3,
- unionUCSs [h1,h3],
- f1)
-
- SCC _ -> return (Note note e1, y1u, h1, f1)
-
- InlineCall -> return (Note note e1, y1u, h1, f1)
-
- InlineMe -> return (Note note e1, y1u, h1, f1)
-
- TermUsg _ -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
-
-usgInfCE ve e0@(Type _)
- = pprPanic "usgInfCE:Type" $ ppr e0
-\end{code}
-
-
-\begin{code}
-lookupVar :: VarEnv Var -> Var -> Var
--- if variable in VarEnv then return annotated version,
--- otherwise it's imported and already annotated so leave alone.
---lookupVar ve v = error "lookupVar unimplemented"
-lookupVar ve v = case lookupVarEnv ve v of
- Just v' -> v'
- Nothing -> ASSERT( not (mustHaveLocalBinding v) )
- ASSERT( isUsgTy (varType v) )
- v
-
-instVar :: Var -> UniqSMM Var
--- instantiate variable with rho-type, giving it a fresh sigma-type
-instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
- case uvs of
- [] -> return v
- _ -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
- let ty' = substUsTy (zipVarEnv uvs uvs') ty
- return (setVarType v ty')
-
-annotVar :: Var -> UniqSMM (Var,Type)
--- freshly annotates a variable and returns it along with its new type
-annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
- return (setVarType v y1u, y1u)
-\end{code}
-
-
-The closure operation, which does the generalisation at let bindings.
-
-\begin{code}
-usgClos :: VarEnv Var -- environment to close with respect to
- -> Type -- type to close (sigma)
- -> UConSet -- constraint set to reduce
- -> (Type, -- closed type (rho)
- UConSet) -- residual constraint set
-
-usgClos zz_ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
-
- -- hmm! what if it sets some uvars to 1 or omega?
- -- (should it do substitution here, or return a substitution,
- -- or should it leave all that work to the end and just use
- -- an "=" constraint here for now?)
-\end{code}
-
-The pessimise operation, which generates constraints to pessimise an
-id (applied to exported ids, to ensure that they have fully general
-types, since we don't know how they will be used in other modules).
-
-\begin{code}
-pessimise :: Type -> UConSet
-
-pessimise ty
- = pess True emptyVarEnv ty
-
- where
- pess :: Bool -> UVarSet -> Type -> UConSet
- pess co ve (NoteTy (UsgForAll uv) ty)
- = pess co (ve `extendVarSet` uv) ty
- pess co ve ty0@(NoteTy (UsgNote u) ty)
- = pessN co ve ty `unionUCS`
- (case (co,u) of
- (False,_ ) -> emptyUConSet
- (True ,UsMany ) -> emptyUConSet
- (True ,UsOnce ) -> pprPanic "pessimise: can't force:" (ppr ty0)
- (True ,UsVar uv) -> if uv `elemVarSet` ve
- then emptyUConSet -- if bound by \/u, no need to pessimise
- else eqManyUConSet u)
- pess _ _ ty0
- = pprPanic "pessimise: missing annot:" (ppr ty0)
-
- pessN :: Bool -> UVarSet -> Type -> UConSet
- pessN co ve (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
- pessN co ve ty0@(NoteTy (UsgNote _) _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
- pessN co ve (NoteTy (SynNote sty) ty) = pessN co ve sty `unionUCS` pessN co ve ty
- pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
- pessN co ve (TyVarTy _) = emptyUConSet
- pessN co ve (AppTy _ _) = emptyUConSet
- pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&( tys `lengthExceeds` 1)) )
- emptyUConSet
- pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
- pessN co ve (ForAllTy _ ty) = pessN co ve ty
-\end{code}
-
-
-
-======================================================================
-
-Helper functions
-~~~~~~~~~~~~~~~~
-
-If a variable appears more than once in an fv set, force its usage to be Many.
-
-\begin{code}
-occChkUConSet :: Var
- -> VarMultiset
- -> UConSet
-
-occChkUConSet v fv = if occInMS v fv > 1
- then ASSERT2( isUsgTy (varType v), ppr v )
- eqManyUConSet ((tyUsg . varType) v)
- else emptyUConSet
-
-occChksUConSet :: [Var]
- -> VarMultiset
- -> UConSet
-
-occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
-\end{code}
-
-
-Subtyping and equal-typing relations. These generate constraint sets.
-Both assume their arguments are annotated correctly, and are either
-both tau-types or both sigma-types (in fact, are both exactly the same
-shape).
-
-\begin{code}
-usgSubTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2
- where cmp u1 u2 = leqUConSet u2 u1
-
-usgEqTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2 -- **NB** doesn't equate tyconargs that
- -- don't appear (see below)
- where cmp u1 u2 = eqUConSet u1 u2
-
-genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet) -- constraint (u1 REL u2), respectively
- -> Type
- -> Type
- -> UConSet
-
-genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
- = cmp u1 u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
-
-#ifndef USMANY
--- deal with omitted == UsMany
-genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
- = cmp u1 UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
-genUsgCmpTy cmp ty1 (NoteTy (UsgNote u2) ty2)
- = cmp UsMany u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
-#endif
-
-genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
- = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
- -- **! is this right? or should I throw away synonyms, or sth else?
-
--- if SynNote only on one side, throw it out
-genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
- = genUsgCmpTy cmp ty1 ty2
-genUsgCmpTy cmp ty1 (NoteTy (SynNote sty2) ty2)
- = genUsgCmpTy cmp ty1 ty2
-
--- ignore FTVNotes
-genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
- = genUsgCmpTy cmp ty1 ty2
-genUsgCmpTy cmp ty1 (NoteTy (FTVNote _) ty2)
- = genUsgCmpTy cmp ty1 ty2
-
-genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
- = emptyUConSet
-
-genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
- = unionUCSs [genUsgCmpTy cmp tya1 tya2,
- genUsgCmpTy cmp tyb1 tyb2, -- note, *both* ways for arg, since fun (prob) unknown
- genUsgCmpTy cmp tyb2 tyb1]
-
-genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
- = case tyConArgVrcs_maybe tc1 of
- Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
- -- strictly this is wasteful (and possibly dangerous) for
- -- usgEqTy, but I think it's OK. KSW 1999-04.
- (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
- `unionUCS`
- (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
- ty1s ty2s oi)
- Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
-
-genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
- = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2 -- contravariance of arrow
-
-genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
- = genUsgCmpTy cmp ty1 ty2
-
-genUsgCmpTy cmp ty1 ty2
- = pprPanic "genUsgCmpTy: type shapes don't match" $
- vcat [ppr ty1, ppr ty2]
-\end{code}
-
-
-Applying a substitution to all @UVar@s. This also moves @TermUsg@
-notes on lambdas into the @lbvarInfo@ field of the binder. This
-latter is a hack. KSW 1999-04.
-
-\begin{code}
-appUSubstTy :: (UVar -> UsageAnn)
- -> Type
- -> Type
-
-appUSubstTy s (NoteTy (UsgNote (UsVar uv)) ty)
- = mkUsgTy (s uv) (appUSubstTy s ty)
-appUSubstTy s (NoteTy note@(UsgNote _) ty) = NoteTy note (appUSubstTy s ty)
-appUSubstTy s (NoteTy note@(SynNote _) ty) = NoteTy note (appUSubstTy s ty)
-appUSubstTy s (NoteTy note@(FTVNote _) ty) = NoteTy note (appUSubstTy s ty)
-appUSubstTy s ty@(TyVarTy _) = ty
-appUSubstTy s (AppTy ty1 ty2) = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
-appUSubstTy s (TyConApp tc tys) = TyConApp tc (map (appUSubstTy s) tys)
-appUSubstTy s (FunTy ty1 ty2) = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
-appUSubstTy s (ForAllTy tyv ty) = ForAllTy tyv (appUSubstTy s ty)
-
-
-appUSubstBinds :: (UVar -> UsageAnn)
- -> [CoreBind]
- -> [CoreBind]
-
-appUSubstBinds s binds = fst $ initAnnotM () $
- genAnnotBinds mungeType mungeTerm binds
- where mungeType _ ty = -- simply perform substitution
- return (appUSubstTy s ty)
-
- mungeTerm (Note (TermUsg (UsVar uv)) (Lam v e))
- -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
- = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
- v' = modifyIdInfo (`setLBVarInfo` lb) v -- HACK ALERT!
- -- see comment in IdInfo.lhs; this is because the info is easier to
- -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
- in return (Lam v' e)
- -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
- mungeTerm e@(Lam _ _) = return e
- mungeTerm e = panic "appUSubstBinds: mungeTerm:" (ppr e)
-\end{code}
-
-
-A @VarMultiset@ is what it says: a set of variables with counts
-attached to them. We build one out of a @VarEnv@.
-
-\begin{code}
-type VarMultiset = VarEnv (Var,Int) -- I guess 536 870 911 occurrences is enough
-
-emptyMS = emptyVarEnv
-unitMS v = unitVarEnv v (v,1)
-delFromMS = delVarEnv
-delsFromMS = delVarEnvList
-plusMS :: VarMultiset -> VarMultiset -> VarMultiset
-plusMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
-maxMS :: VarMultiset -> VarMultiset -> VarMultiset
-maxMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
-mapMS f = mapVarEnv (\ (v,n) -> f v n)
-foldMS f = foldVarEnv (\ (v,n) a -> f v n a)
-occInMS v ms = case lookupVarEnv ms v of
- Just (_,n) -> n
- Nothing -> 0
-\end{code}
-
-And a function used in debugging. It may give false positives with -DUSMANY turned off.
-
-\begin{code}
-isUnAnnotated :: Type -> Bool
-
-isUnAnnotated (NoteTy (UsgNote _ ) _ ) = False
-isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
-isUnAnnotated (NoteTy (FTVNote _ ) ty) = isUnAnnotated ty
-isUnAnnotated (TyVarTy _) = True
-isUnAnnotated (AppTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
-isUnAnnotated (TyConApp tc tys) = all isUnAnnotated tys
-isUnAnnotated (FunTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
-isUnAnnotated (ForAllTy tyv ty) = isUnAnnotated ty
-
-
-END OF ENTIRELY-COMMENTED-OUT PASS -- KSW 2000-10-13 -}
-\end{code}
-
-======================================================================
-
-EOF
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[UsageSPLint]{UsageSP ``lint'' pass}
-
-This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
-September 1998 .. May 1999.
-
-Keith Wansbrough 1998-09-04..1999-06-25
-
-\begin{code}
-module UsageSPLint ( {- SEE BELOW: -- KSW 2000-10-13
- doLintUSPAnnotsBinds,
- doLintUSPConstBinds,
- doLintUSPBinds,
- doCheckIfWorseUSP, -}
- ) where
-
-#include "HsVersions.h"
-
-import UsageSPUtils
-import CoreSyn
-import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( )
-import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
-import Var ( Var, varType )
-import Id ( idLBVarInfo )
-import IdInfo ( LBVarInfo(..) )
-import ErrUtils ( ghcExit )
-import Util ( zipWithEqual )
-import Bag
-import Outputable
-
-{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
-
- This monomorphic version of the analysis is outdated. I'm
- currently ripping out the old one and inserting the new one. For
- now, I'm simply commenting out this entire file.
-
-\end{code}
-
-======================================================================
-
-Interface
-~~~~~~~~~
-
-@doLintUSPAnnotsBinds@ checks that annotations are in the correct positions.
-@doLintUSPConstsBinds@ checks that no @UVar@s remain anywhere (i.e., all annots are constants).
-@doLintUSPBinds@ checks that the annotations are consistent. [unimplemented!]
-@doCheckIfWorseUSP@ checks that annots on binders have not changed from Once to Many.
-
-\begin{code}
-doLint :: ULintM a -> IO ()
-
-doLint m = case runULM m of
- Nothing -> return ()
- Just bad_news -> do { printDump (display bad_news)
- ; ghcExit 1
- }
- where display bad_news = vcat [ text "*** LintUSP errors: ***"
- , bad_news
- , text "*** end of LintUSP errors ***"
- ]
-
-doLintUSPAnnotsBinds, doLintUSPConstBinds :: [CoreBind] -> IO ()
-
-doLintUSPAnnotsBinds = doLint . lintUSPAnnotsBinds
-doLintUSPConstBinds = doLint . lintUSPConstBinds
-
--- doLintUSPBinds is defined below
-
-doCheckIfWorseUSP :: [CoreBind] -> [CoreBind] -> IO ()
-
-doCheckIfWorseUSP binds binds'
- = case checkIfWorseUSP binds binds' of
- Nothing -> return ()
- Just warns -> printDump warns
-\end{code}
-
-======================================================================
-
-Verifying correct annotation positioning
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following functions check whether the usage annotations are
-correctly placed on a type. They sit inside the lint monad.
-@lintUSPAnnots@ assumes there should be an outermost annotation,
-@lintUSPAnnotsN@ assumes there shouldn't.
-
-The fact that no general catch-all pattern is given for @NoteTy@s is
-entirely intentional. The meaning of future extensions here is
-entirely unknown, so you'll have to decide how to check them
-explicitly.
-
-\begin{code}
-lintTyUSPAnnots :: Bool -- die on omitted annotation?
- -> Bool -- die on extra annotation?
- -> Type -- type to check
- -> ULintM ()
-
-lintTyUSPAnnots fom fex = lint
- where
- lint (NoteTy (UsgNote _) ty) = lintTyUSPAnnotsN fom fex ty
- lint ty0 = do { mayErrULM fom "missing UsgNote" ty0
- ; lintTyUSPAnnotsN fom fex ty0
- }
-
-lintTyUSPAnnotsN :: Bool -- die on omitted annotation?
- -> Bool -- die on extra annotation?
- -> Type -- type to check
- -> ULintM ()
-
-lintTyUSPAnnotsN fom fex = lintN
- where
- lintN ty0@(NoteTy (UsgNote _) ty) = do { mayErrULM fex "unexpected UsgNote" ty0
- ; lintN ty
- }
- lintN (NoteTy (SynNote sty) ty) = do { lintN sty
- ; lintN ty
- }
- lintN (NoteTy (FTVNote _) ty) = do { lintN ty }
-
- lintN (TyVarTy _) = do { return () }
- lintN (AppTy ty1 ty2) = do { lintN ty1
- ; lintN ty2
- }
- lintN (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
- do { let thelint = if isFunTyCon tc
- then lintTyUSPAnnots fom fex
- else lintN
- ; mapM_ thelint tys
- ; return ()
- }
- lintN (FunTy ty1 ty2) = do { lintTyUSPAnnots fom fex ty1
- ; lintTyUSPAnnots fom fex ty2
- }
- lintN (ForAllTy _ ty) = do { lintN ty }
-\end{code}
-
-
-Now the combined function that takes a @MungeFlags@ to tell it what to
-do to a particular type. This is passed to @genAnnotBinds@ to get the
-work done.
-
-\begin{code}
-lintUSPAnnotsTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
-
-lintUSPAnnotsTyM mf ty = AnnotM $ \ m ve ->
- (ty, do { m
- ; atLocULM (mfLoc mf) $
- (if isSigma mf
- then lintTyUSPAnnots
- else lintTyUSPAnnotsN) checkOmitted True ty
- },
- ve)
-#ifndef USMANY
- where checkOmitted = False -- OK to omit Many if !USMANY
-#else
- where checkOmitted = True -- require all annotations
-#endif
-
-lintUSPAnnotsBinds :: [CoreBind]
- -> ULintM ()
-
-lintUSPAnnotsBinds binds = case initAnnotM (return ()) $
- genAnnotBinds lintUSPAnnotsTyM return binds of
- -- **! should check with mungeTerm too!
- (_,m) -> m
-\end{code}
-
-======================================================================
-
-Verifying correct usage typing
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following function verifies that all usage annotations are
-consistent. It assumes that there are no usage variables, only
-@UsOnce@ and @UsMany@ annotations.
-
-This is very similar to usage inference, however, and so we could
-simply use that, with a little work. For now, it's unimplemented.
-
-\begin{code}
-doLintUSPBinds :: [CoreBind] -> IO ()
-
-doLintUSPBinds binds = panic "doLintUSPBinds unimplemented"
- {- case initUs us (uniqSMMToUs (usgInfBinds binds)) of
- ((ucs,_),_) -> if isJust (solveUCS ucs)
- then return ()
- else do { printDump (text "*** LintUSPBinds failed ***")
- ; ghcExit 1
- }
- -}
-\end{code}
-
-======================================================================
-
-Verifying usage constants only (not vars)
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following function checks that all usage annotations are ground,
-i.e., @UsOnce@ or @UsMany@: no @UVar@s remain.
-
-\begin{code}
-lintTyUSPConst :: Type
- -> ULintM ()
-
-lintTyUSPConst (TyVarTy _) = do { return () }
-
-lintTyUSPConst (AppTy ty1 ty2) = do { lintTyUSPConst ty1
- ; lintTyUSPConst ty2
- }
-lintTyUSPConst (TyConApp tc tys) = mapM_ lintTyUSPConst tys
-lintTyUSPConst (FunTy ty1 ty2) = do { lintTyUSPConst ty1
- ; lintTyUSPConst ty2
- }
-lintTyUSPConst (ForAllTy _ ty) = do { lintTyUSPConst ty }
-
-lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
- ; lintTyUSPConst ty
- }
-lintTyUSPConst ty0@(NoteTy (UsgNote _) ty) = do { lintTyUSPConst ty }
-lintTyUSPConst ty0@(NoteTy (SynNote sty) ty) = do { lintTyUSPConst sty
- ; lintTyUSPConst ty
- }
-lintTyUSPConst ty0@(NoteTy (FTVNote _) ty) = do { lintTyUSPConst ty }
-\end{code}
-
-
-Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
-
-\begin{code}
-lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
-
-lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
- (ty,
- do { m
- ; atLocULM (mfLoc mf) $
- lintTyUSPConst ty
- },
- ve)
-
-lintUSPConstBinds :: [CoreBind]
- -> ULintM ()
-
-lintUSPConstBinds binds = case initAnnotM (return ()) $
- genAnnotBinds lintUSPConstTyM return binds of
- -- **! should check with mungeTerm too!
- (_,m) -> m
-\end{code}
-
-======================================================================
-
-Checking annotations don't get any worse
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-It is assumed that all transformations in GHC are `work-safe', that
-is, they do not cause any work to be duplicated. Thus they should
-also be safe wrt the UsageSP analysis: if an identifier has a
-used-once type at one point, the identifier should never become
-used-many after transformation. This check verifies that this is the
-case.
-
-The arguments are the CoreBinds before and after the inference. They
-must have exactly the same shape apart from usage annotations.
-
-We only bother checking binders; free variables *should* be fixed
-already since they are imported and not changeable.
-
-First, the various kinds of worsenings we can have:
-
-\begin{code}
-data WorseErr = WorseVar Var Var -- variable gets worse
- | WorseTerm CoreExpr CoreExpr -- term gets worse
- | WorseLam Var Var -- lambda gets worse
-
-instance Outputable WorseErr where
- ppr (WorseVar v0 v) = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
- <+> ( ptext SLIT("was") <+> ppr (varType v0)
- $$ ptext SLIT("now") <+> ppr (varType v))
- ppr (WorseTerm e0 e) = ptext SLIT("Term:")
- <+> ( ptext SLIT("was") <+> ppr e0
- $$ ptext SLIT("now") <+> ppr e)
- ppr (WorseLam v0 v) = ptext SLIT("Lambda:")
- <+> ( ppr v0
- $$ ptext SLIT("(lambda-bound var info for var worsened)"))
-\end{code}
-
-Now the checker.
-
-\begin{code}
-checkIfWorseUSP :: [CoreBind] -- old binds
- -> [CoreBind] -- new binds
- -> Maybe SDoc -- maybe warnings
-
-checkIfWorseUSP binds binds'
- = let vvs = checkBinds binds binds'
- in if isEmptyBag vvs then
- Nothing
- else
- Just $ ptext SLIT("UsageSP warning: annotations worsen for")
- $$ nest 4 (vcat (map ppr (bagToList vvs)))
-
-checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
-checkBinds binds binds' = unionManyBags $
- zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
-
-checkBind :: CoreBind -> CoreBind -> Bag WorseErr
-checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
-checkBind (Rec ves) (Rec ves') = unionManyBags $
- zipWithEqual "UsageSPLint.checkBind"
- (\ (v,e) (v',e') -> (checkVar v v')
- `unionBags` (checkCE e e'))
- ves ves'
-checkBind _ _ = panic "UsageSPLint.checkBind"
-
-
-checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
-
-checkCE (Var _) (Var _) = emptyBag
-checkCE (Lit _) (Lit _) = emptyBag
-
-checkCE (App e arg) (App e' arg') = (checkCE e e')
- `unionBags` (checkCE arg arg')
-
-checkCE (Lam v e) (Lam v' e') = (checkVar v v')
- `unionBags` (checkLamVar v v')
- `unionBags` (checkCE e e')
-
-checkCE (Let bind e) (Let bind' e') = (checkBind bind bind')
- `unionBags` (checkCE e e')
-
-checkCE (Case e v alts) (Case e' v' alts')
- = (checkCE e e')
- `unionBags` (checkVar v v')
- `unionBags` (unionManyBags $
- zipWithEqual "usageSPLint.checkCE:Case"
- checkAlts alts alts')
- where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
- checkVar vs vs')
- `unionBags` (checkCE e e')
-
-checkCE (Note (SCC _) e) (Note (SCC _) e') = checkCE e e'
-
-checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
-
-checkCE (Note InlineCall e) (Note InlineCall e') = checkCE e e'
-
-checkCE (Note InlineMe e) (Note InlineMe e') = checkCE e e'
-
-checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
- = checkCE e e'
- `unionBags` (checkUsg u u' (WorseTerm t t'))
-
-checkCE (Type _) (Type _) = emptyBag
-
-checkCE t t' = pprPanic "usageSPLint.checkCE:"
- (ppr t $$ text "doesn't match" <+> ppr t')
-
-
--- does binder change from Once to Many?
--- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04.
-checkVar :: Var -> Var -> Bag WorseErr
-checkVar v v' | isTyVar v = emptyBag
- | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK
- | otherwise = checkUsg u u' (WorseVar v v')
- where y = varType v
- y' = varType v'
- u = tyUsg y
- u' = tyUsg y'
-
--- does lambda change from Once to Many?
-checkLamVar :: Var -> Var -> Bag WorseErr
-checkLamVar v v' | isTyVar v = emptyBag
- | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
- (NoLBVarInfo , _ ) -> emptyBag
- (IsOneShotLambda, IsOneShotLambda) -> emptyBag
- (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v')
-
--- does term usage annotation change from Once to Many?
-checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
-checkUsg UsMany _ _ = emptyBag
-checkUsg UsOnce UsOnce _ = emptyBag
-checkUsg UsOnce UsMany err = unitBag err
-\end{code}
-
-======================================================================
-
-Lint monad stuff
-~~~~~~~~~~~~~~~~
-
-The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
-also tracks the location of the current type being checked.
-
-\begin{code}
-data ULintErr = ULintErr SDoc String Type
-
-pprULintErr :: ULintErr -> SDoc
-pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
- 4 (ppr ty)
-
-
-newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
-unULintM (ULintM f) = f
-
-instance Monad ULintM where
- m >>= f = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
- (a',errs') = (unULintM (f a)) loc
- in (a', errs `unionBags` errs')
- return a = ULintM $ \ _ -> (a,emptyBag)
-
-atLocULM :: SDoc -> ULintM a -> ULintM a
-atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
-
-errULM :: String -> Type -> ULintM ()
-errULM err ty
- = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
-
-mayErrULM :: Bool -> String -> Type -> ULintM ()
-mayErrULM f err ty
- = if f then errULM err ty else return ()
-
-runULM :: ULintM a -> Maybe SDoc
-runULM m = case (unULintM m) (panic "runULM: no location") of
- (_,errs) -> if isEmptyBag errs
- then Nothing
- else Just (vcat (map pprULintErr (bagToList errs)))
-
-END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
-\end{code}
-
-======================================================================
-
-EOF
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1998
-%
-\section[UsageSPUtils]{UsageSP Utilities}
-
-This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
-September 1998 .. May 1999.
-
-Keith Wansbrough 1998-09-04..1999-07-07
-
-\begin{code}
-module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13
- AnnotM(AnnotM), initAnnotM,
- genAnnotBinds,
- MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
-
- doAnnotBinds, doUnAnnotBinds,
- annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
-
- newVarUs, newVarUSMM,
- UniqSMM, usToUniqSMM, uniqSMMToUs,
-
- primOpUsgTys, -}
- ) where
-
-#include "HsVersions.h"
-
-{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
-import CoreSyn
-import Var ( Var, varType, setVarType, mkUVar )
-import Id ( isExportedId )
-import Name ( isLocallyDefined )
-import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( splitFunTys )
-import Subst ( substTy, mkTyVarSubst )
-import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
-import VarEnv
-import PrimOp ( PrimOp, primOpUsg )
-import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs )
-import Util ( lengthExceeds )
-import Outputable
-
-
- This monomorphic version of the analysis is outdated. I'm
- currently ripping out the old one and inserting the new one. For
- now, I'm simply commenting out this entire file.
-
-
-\end{code}
-
-======================================================================
-
-Walking over (and altering) types
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We often need to fiddle with (i.e., add or remove) usage annotations
-on a type. We define here a general framework to do this. Usage
-annotations come from any monad with a function @getAnnM@ which yields
-a new annotation. We use two mutually recursive functions, one for
-sigma types and one for tau types.
-
-\begin{code}
-genAnnotTy :: Monad m =>
- (m UsageAnn) -- get new annotation
- -> Type -- old type
- -> m Type -- new type
-
-genAnnotTy getAnnM ty = do { u <- getAnnM
- ; ty' <- genAnnotTyN getAnnM ty
- ; return (NoteTy (UsgNote u) ty')
- }
-
-genAnnotTyN :: Monad m =>
- (m UsageAnn)
- -> Type
- -> m Type
-
-genAnnotTyN getAnnM
- (NoteTy (UsgNote _) ty) = panic "genAnnotTyN: unexpected UsgNote"
-genAnnotTyN getAnnM
- (NoteTy (SynNote sty) ty) = do { sty' <- genAnnotTyN getAnnM sty
- -- is this right? shouldn't there be some
- -- correlation between sty' and ty'?
- -- But sty is a TyConApp; does this make it safer?
- ; ty' <- genAnnotTyN getAnnM ty
- ; return (NoteTy (SynNote sty') ty')
- }
-genAnnotTyN getAnnM
- (NoteTy fvn@(FTVNote _) ty) = do { ty' <- genAnnotTyN getAnnM ty
- ; return (NoteTy fvn ty')
- }
-
-genAnnotTyN getAnnM
- ty0@(TyVarTy _) = do { return ty0 }
-
-genAnnotTyN getAnnM
- (AppTy ty1 ty2) = do { ty1' <- genAnnotTyN getAnnM ty1
- ; ty2' <- genAnnotTyN getAnnM ty2
- ; return (AppTy ty1' ty2')
- }
-
-genAnnotTyN getAnnM
- (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
- do { let gAT = if isFunTyCon tc
- then genAnnotTy -- sigma for partial apps of (->)
- else genAnnotTyN -- tau otherwise
- ; tys' <- mapM (gAT getAnnM) tys
- ; return (TyConApp tc tys')
- }
-
-genAnnotTyN getAnnM
- (FunTy ty1 ty2) = do { ty1' <- genAnnotTy getAnnM ty1
- ; ty2' <- genAnnotTy getAnnM ty2
- ; return (FunTy ty1' ty2')
- }
-
-genAnnotTyN getAnnM
- (ForAllTy v ty) = do { ty' <- genAnnotTyN getAnnM ty
- ; return (ForAllTy v ty')
- }
-\end{code}
-
-
-
-Walking over (and retyping) terms
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We also often need to play with the types in a term. This is slightly
-tricky because of redundancy: we want to change binder types, and keep
-the bound types matching these; then there's a special case also with
-non-locally-defined bound variables. We generalise over all this
-here.
-
-The name `annot' is a bit of a misnomer, as the code is parameterised
-over exactly what it does to the types (and certain terms). Notice
-also that it is possible for this parameter to use
-monadically-threaded state: here called `flexi'. For genuine
-annotation, this state will be a UniqSupply.
-
-We may add annotations to the outside of a (term, not type) lambda; a
-function passed to @genAnnotBinds@ does this, taking the lambda and
-returning the annotated lambda. It is inside the @AnnotM@ monad.
-This term-munging function is applied when we see either a term lambda
-or a usage annotation; *IMPORTANT:* it is applied *before* we recurse
-down into the term, and it is expected to work only at the top level.
-Recursion will subsequently be done by genAnnotBinds. It may
-optionally remove a Note TermUsg, or optionally add one if it is not
-already present, but it may perform NO OTHER MODIFICATIONS to the
-structure of the term.
-
-We do different things to types of variables bound locally and of
-variables bound in other modules, in certain cases: the former get
-uvars and the latter keep their existing annotations when we annotate,
-for example. To control this, @MungeFlags@ describes what kind of a
-type this is that we're about to munge.
-
-\begin{code}
-data MungeFlags = MungeFlags { isSigma :: Bool, -- want annotated on top (sigma type)
- isLocal :: Bool, -- is locally-defined type
- hasUsg :: Bool, -- has fixed usage info, don't touch
- isExp :: Bool, -- is exported (and must be pessimised)
- mfLoc :: SDoc -- location info
- }
-
-tauTyMF loc = MungeFlags { isSigma = False, isLocal = True,
- hasUsg = False, isExp = False, mfLoc = loc }
-sigVarTyMF v = MungeFlags { isSigma = True, isLocal = hasLocalDef v,
- hasUsg = hasUsgInfo v, isExp = isExportedId v,
- mfLoc = ptext SLIT("type of binder") <+> ppr v }
-\end{code}
-
-The helper functions @tauTyMF@ and @sigVarTyMF@ create @MungeFlags@
-for us. @sigVarTyMF@ checks the variable to see how to set the flags.
-
-@hasLocalDef@ tells us if the given variable has an actual local
-definition that we can play with. This is not quite the same as
-@isLocallyDefined@, since @hasNoBindingId@ things (usually) don't have
-a local definition - the simplifier will inline whatever their
-unfolding is anyway. We treat these as if they were externally
-defined, since we don't have access to their definition (at least not
-easily). This doesn't hurt much, since after the simplifier has run
-the unfolding will have been inlined and we can access the unfolding
-directly.
-
-@hasUsgInfo@, on the other hand, says if the variable already has
-usage info in its type that must at all costs be preserved. This is
-assumed true (exactly) of all imported ids.
-
-\begin{code}
-hasLocalDef :: Var -> Bool
-hasLocalDef var = mustHaveLocalBinding var
-
-hasUsgInfo :: Var -> Bool
-hasUsgInfo var = (not . isLocallyDefined) var
-\end{code}
-
-Here's the walk itself.
-
-\begin{code}
-genAnnotBinds :: (MungeFlags -> Type -> AnnotM flexi Type)
- -> (CoreExpr -> AnnotM flexi CoreExpr) -- see caveats above
- -> [CoreBind]
- -> AnnotM flexi [CoreBind]
-
-genAnnotBinds _ _ [] = return []
-
-genAnnotBinds f g (b:bs) = do { (b',vs,vs') <- genAnnotBind f g b
- ; bs' <- withAnnVars vs vs' $
- genAnnotBinds f g bs
- ; return (b':bs')
- }
-
-genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering function
- -> (CoreExpr -> AnnotM flexi CoreExpr) -- term-altering function
- -> CoreBind -- original CoreBind
- -> AnnotM flexi
- (CoreBind, -- annotated CoreBind
- [Var], -- old variables, to be mapped to...
- [Var]) -- ... new variables
-
-genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1
- ; e1' <- genAnnotCE f g e1
- ; return (NonRec v1' e1', [v1], [v1'])
- }
-
-genAnnotBind f g (Rec ves) = do { let (vs,es) = unzip ves
- ; vs' <- mapM (genAnnotVar f) vs
- ; es' <- withAnnVars vs vs' $
- mapM (genAnnotCE f g) es
- ; return (Rec (zip vs' es'), vs, vs')
- }
-
-genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering function
- -> (CoreExpr -> AnnotM flexi CoreExpr) -- term-altering function
- -> CoreExpr -- original expression
- -> AnnotM flexi CoreExpr -- yields new expression
-
-genAnnotCE mungeType mungeTerm = go
- where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of constructor
- -- (no it doesn't: (Type (TyVar tyvar))
- | otherwise = do { mv' <- lookupAnnVar v
- ; v' <- case mv' of
- Just var -> return var
- Nothing -> fixedVar v
- ; return (Var v')
- }
-
- go (Lit l) = -- we know it's saturated
- return (Lit l)
-
- go (App e arg) = do { e' <- go e
- ; arg' <- go arg
- ; return (App e' arg')
- }
-
- go e0@(Lam v0 _) = do { e1 <- (if isTyVar v0 then return else mungeTerm) e0
- ; let (v,e2,wrap)
- = case e1 of -- munge may have added note
- Note tu@(TermUsg _) (Lam v e2)
- -> (v,e2,Note tu)
- Lam v e2 -> (v,e2,id)
- ; v' <- genAnnotVar mungeType v
- ; e' <- withAnnVar v v' $ go e2
- ; return (wrap (Lam v' e'))
- }
-
- go (Let bind e) = do { (bind',vs,vs') <- genAnnotBind mungeType mungeTerm bind
- ; e' <- withAnnVars vs vs' $ go e
- ; return (Let bind' e')
- }
-
- go (Case e v alts) = do { e' <- go e
- ; v' <- genAnnotVar mungeType v
- ; alts' <- withAnnVar v v' $ mapM genAnnotAlt alts
- ; return (Case e' v' alts')
- }
-
- go (Note scc@(SCC _) e) = do { e' <- go e
- ; return (Note scc e')
- }
- go e0@(Note (Coerce ty1 ty0)
- e) = do { ty1' <- mungeType
- (tauTyMF (ptext SLIT("coercer of")
- <+> ppr e0)) ty1
- ; ty0' <- mungeType
- (tauTyMF (ptext SLIT("coercee of")
- <+> ppr e0)) ty0
- -- (Better to specify ty0'
- -- identical to the type of e, including
- -- annotations, right at the beginning, but
- -- not possible at this point.)
- ; e' <- go e
- ; return (Note (Coerce ty1' ty0') e')
- }
- go (Note InlineCall e) = do { e' <- go e
- ; return (Note InlineCall e')
- }
- go (Note InlineMe e) = do { e' <- go e
- ; return (Note InlineMe e')
- }
- go e0@(Note (TermUsg _) _) = do { e1 <- mungeTerm e0
- ; case e1 of -- munge may have removed note
- Note tu@(TermUsg _) e2 -> do { e3 <- go e2
- ; return (Note tu e3)
- }
- e2 -> go e2
- }
-
- go e0@(Type ty) = -- should only occur at toplevel of Arg,
- -- hence tau-type
- do { ty' <- mungeType
- (tauTyMF (ptext SLIT("tyarg")
- <+> ppr e0)) ty
- ; return (Type ty')
- }
-
- fixedVar v = ASSERT2( not (hasLocalDef v), text "genAnnotCE: locally defined var" <+> ppr v <+> text "not in varenv" )
- genAnnotVar mungeType v
-
- genAnnotAlt (c,vs,e) = do { vs' <- mapM (genAnnotVar mungeType) vs
- ; e' <- withAnnVars vs vs' $ go e
- ; return (c, vs', e')
- }
-
-
-genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type)
- -> Var
- -> AnnotM flexi Var
-
-genAnnotVar mungeType v | isTyVar v = return v
- | otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
- ; return (setVarType v vty')
- }
-{- ifdef DEBUG
- ; return $
- pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $
- (setVarType v vty')
- endif
- -}
-\end{code}
-
-======================================================================
-
-Some specific things to do to types inside terms
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-@annotTyM@ annotates a type with fresh uvars everywhere the inference
-is allowed to go, and leaves alone annotations where it may not go.
-
-We assume there are no annotations already.
-
-\begin{code}
-annotTyM :: MungeFlags -> Type -> AnnotM UniqSupply Type
--- general function
-annotTyM mf ty = uniqSMtoAnnotM . uniqSMMToUs $
- case (hasUsg mf, isLocal mf, isSigma mf) of
- (True ,_ ,_ ) -> ASSERT( isUsgTy ty )
- return ty
- (False,True ,True ) -> if isExp mf then
- annotTyP (tag 'p') ty
- else
- annotTy (tag 's') ty
- (False,True ,False) -> annotTyN (tag 't') ty
- (False,False,True ) -> return $ annotMany ty -- assume worst
- (False,False,False) -> return $ annotManyN ty
- where tag c = Right $ "annotTyM:" ++ [c] ++ ": " ++ showSDoc (ppr ty)
-
--- specific functions for annotating tau and sigma types
-
--- ...with uvars
-annotTy tag = genAnnotTy (newVarUSMM tag)
-annotTyN tag = genAnnotTyN (newVarUSMM tag)
-
--- ...with uvars and pessimal Manys (for exported ids)
-annotTyP tag ty = do { ty' <- annotTy tag ty ; return (pessimise True ty') }
-
--- ...with Many
-annotMany, annotManyN :: Type -> Type
-#ifndef USMANY
-annotMany = id
-annotManyN = id
-#else
-annotMany ty = unId (genAnnotTy (return UsMany) ty)
-annotManyN ty = unId (genAnnotTyN (return UsMany) ty)
-#endif
-
--- monad required for the above
-newtype Id a = Id a ; unId (Id a) = a
-instance Monad Id where { a >>= f = f (unId a) ; return a = Id a }
-
--- lambda-annotating function for use along with the above
-annotLam e0@(Lam v e) = do { uv <- uniqSMtoAnnotM $ newVarUs (Left e0)
- ; return (Note (TermUsg uv) (Lam v e))
- }
-annotLam (Note (TermUsg _) _) = panic "annotLam: unexpected term usage annot"
-\end{code}
-
-The above requires a `pessimising' translation. This is applied to
-types of exported ids, and ensures that they have a fully general
-type (since we don't know how they will be used in other modules).
-
-\begin{code}
-pessimise :: Bool -> Type -> Type
-
-#ifndef USMANY
-pessimise co ty0@(NoteTy usg@(UsgNote u ) ty)
- = if co
- then case u of UsMany -> pty
- UsVar _ -> pty -- force to UsMany
- UsOnce -> pprPanic "pessimise:" (ppr ty0)
- else NoteTy usg pty
- where pty = pessimiseN co ty
-
-pessimise co ty0 = pessimiseN co ty0 -- assume UsMany
-#else
-pessimise co ty0@(NoteTy usg@(UsgNote u ) ty)
- = if co
- then case u of UsMany -> NoteTy usg pty
- UsVar _ -> NoteTy (UsgNote UsMany) pty
- UsOnce -> pprPanic "pessimise:" (ppr ty0)
- else NoteTy usg pty
- where pty = pessimiseN co ty
-
-pessimise co ty0 = pprPanic "pessimise: missing usage note:" $
- ppr ty0
-#endif
-
-pessimiseN co ty0@(NoteTy usg@(UsgNote _ ) ty) = pprPanic "pessimiseN: unexpected usage note:" $
- ppr ty0
-pessimiseN co (NoteTy (SynNote sty) ty) = NoteTy (SynNote (pessimiseN co sty))
- (pessimiseN co ty )
-pessimiseN co (NoteTy note@(FTVNote _ ) ty) = NoteTy note (pessimiseN co ty)
-pessimiseN co ty0@(TyVarTy _) = ty0
-pessimiseN co ty0@(AppTy _ _) = ty0
-pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (tys `lengthExceeds` 1)) )
- ty0
-pessimiseN co (FunTy ty1 ty2) = FunTy (pessimise (not co) ty1)
- (pessimise co ty2)
-pessimiseN co (ForAllTy tyv ty) = ForAllTy tyv (pessimiseN co ty)
-\end{code}
-
-
-@unAnnotTyM@ strips annotations (that the inference is allowed to
-touch) from a term, and `fixes' those it isn't permitted to touch (by
-putting @Many@ annotations where they are missing, but leaving
-existing annotations in the type).
-
-@unTermUsg@ removes from a term any term usage annotations it finds.
-
-\begin{code}
-unAnnotTyM :: MungeFlags -> Type -> AnnotM a Type
-
-unAnnotTyM mf ty = if hasUsg mf then
- ASSERT( isSigma mf )
- return (fixAnnotTy ty)
- else return (unannotTy ty)
-
-
-unTermUsg :: CoreExpr -> AnnotM a CoreExpr
--- strip all term annotations
-unTermUsg e@(Lam _ _) = return e
-unTermUsg (Note (TermUsg _) e) = return e
-unTermUsg _ = panic "unTermUsg"
-
-unannotTy :: Type -> Type
--- strip all annotations
-unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty
-unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
-unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
-unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
-unannotTy ty@(PredTy _) = ty -- PredTys need to be preserved
-unannotTy ty@(TyVarTy _) = ty
-unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
-unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
-unannotTy (FunTy ty1 ty2) = FunTy (unannotTy ty1) (unannotTy ty2)
-unannotTy (ForAllTy tyv ty) = ForAllTy tyv (unannotTy ty)
-
-
-fixAnnotTy :: Type -> Type
--- put Manys where they are missing
-#ifndef USMANY
-fixAnnotTy = id
-#else
-fixAnnotTy (NoteTy note@(UsgForAll uv) ty) = NoteTy note (fixAnnotTy ty)
-fixAnnotTy (NoteTy note@(UsgNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
-fixAnnotTy ty0 = NoteTy (UsgNote UsMany) (fixAnnotTyN ty0)
-
-fixAnnotTyN ty0@(NoteTy note@(UsgNote _ ) ty) = pprPanic "fixAnnotTyN: unexpected usage note:" $
- ppr ty0
-fixAnnotTyN (NoteTy (SynNote sty) ty) = NoteTy (SynNote (fixAnnotTyN sty))
- (fixAnnotTyN ty )
-fixAnnotTyN (NoteTy note@(FTVNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
-fixAnnotTyN ty0@(TyVarTy _) = ty0
-fixAnnotTyN (AppTy ty1 ty2) = AppTy (fixAnnotTyN ty1) (fixAnnotTyN ty2)
-fixAnnotTyN (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
- TyConApp tc (map (if isFunTyCon tc then
- fixAnnotTy
- else
- fixAnnotTyN) tys)
-fixAnnotTyN (FunTy ty1 ty2) = FunTy (fixAnnotTy ty1) (fixAnnotTy ty2)
-fixAnnotTyN (ForAllTy tyv ty) = ForAllTy tyv (fixAnnotTyN ty)
-#endif
-\end{code}
-
-The composition (reannotating a type with fresh uvars but the same
-structure) is useful elsewhere:
-
-\begin{code}
-freshannotTy :: Type -> UniqSMM Type
-freshannotTy = annotTy (Right "freshannotTy") . unannotTy
-\end{code}
-
-
-Wrappers apply these functions to sets of bindings.
-
-\begin{code}
-doAnnotBinds :: UniqSupply
- -> [CoreBind]
- -> ([CoreBind],UniqSupply)
-
-doAnnotBinds us binds = initAnnotM us (genAnnotBinds annotTyM annotLam binds)
-
-
-doUnAnnotBinds :: [CoreBind]
- -> [CoreBind]
-
-doUnAnnotBinds binds = fst $ initAnnotM () $
- genAnnotBinds unAnnotTyM unTermUsg binds
-\end{code}
-
-======================================================================
-
-Monadic machinery
-~~~~~~~~~~~~~~~~~
-
-The @UniqSM@ type is not an instance of @Monad@, and cannot be made so
-since it is merely a synonym rather than a newtype. Here we define
-@UniqSMM@, which *is* an instance of @Monad@.
-
-\begin{code}
-newtype UniqSMM a = UsToUniqSMM (UniqSM a)
-uniqSMMToUs (UsToUniqSMM us) = us
-usToUniqSMM = UsToUniqSMM
-
-instance Monad UniqSMM where
- m >>= f = UsToUniqSMM $ uniqSMMToUs m `thenUs` \ a ->
- uniqSMMToUs (f a)
- return = UsToUniqSMM . returnUs
-\end{code}
-
-
-For annotation, the monad @AnnotM@, we need to carry around our
-variable mapping, along with some general state.
-
-\begin{code}
-newtype AnnotM flexi a = AnnotM ( flexi -- UniqSupply etc
- -> VarEnv Var -- unannotated to annotated variables
- -> (a,flexi,VarEnv Var))
-unAnnotM (AnnotM f) = f
-
-instance Monad (AnnotM flexi) where
- a >>= f = AnnotM (\ us ve -> let (r,us',ve') = unAnnotM a us ve
- in unAnnotM (f r) us' ve')
- return a = AnnotM (\ us ve -> (a,us,ve))
-
-initAnnotM :: fl -> AnnotM fl a -> (a,fl)
-initAnnotM fl m = case (unAnnotM m) fl emptyVarEnv of { (r,fl',_) -> (r,fl') }
-
-withAnnVar :: Var -> Var -> AnnotM fl a -> AnnotM fl a
-withAnnVar v v' m = AnnotM (\ us ve -> let ve' = extendVarEnv ve v v'
- (r,us',_) = (unAnnotM m) us ve'
- in (r,us',ve))
-
-withAnnVars :: [Var] -> [Var] -> AnnotM fl a -> AnnotM fl a
-withAnnVars vs vs' m = AnnotM (\ us ve -> let ve' = plusVarEnv ve (zipVarEnv vs vs')
- (r,us',_) = (unAnnotM m) us ve'
- in (r,us',ve))
-
-lookupAnnVar :: Var -> AnnotM fl (Maybe Var)
-lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var,
- us,
- ve))
-\end{code}
-
-A useful helper allows us to turn a computation in the unique supply
-monad into one in the annotation monad parameterised by a unique
-supply.
-
-\begin{code}
-uniqSMtoAnnotM :: UniqSM a -> AnnotM UniqSupply a
-
-uniqSMtoAnnotM m = AnnotM (\ us ve -> let (r,us') = initUs us m
- in (r,us',ve))
-\end{code}
-
-@newVarUs@ and @newVarUSMM@ generate a new usage variable. They take
-an argument which is used for debugging only, describing what the
-variable is to annotate.
-
-\begin{code}
-newVarUs :: (Either CoreExpr String) -> UniqSM UsageAnn
--- the first arg is for debugging use only
-newVarUs e = getUniqueUs `thenUs` \ u ->
- let uv = mkUVar u in
- returnUs (UsVar uv)
-{- #ifdef DEBUG
- let src = case e of
- Left (Lit _) -> "literal"
- Left (Lam v e) -> "lambda: " ++ showSDoc (ppr v)
- Left _ -> "unknown"
- Right s -> s
- in pprTrace "newVarUs:" (ppr uv <+> text src) $
- #endif
- -}
-
-newVarUSMM :: (Either CoreExpr String) -> UniqSMM UsageAnn
-newVarUSMM = usToUniqSMM . newVarUs
-\end{code}
-
-======================================================================
-
-PrimOps and usage information.
-
-Analagously to @DataCon.dataConArgTys@, we determine the argtys and
-result ty of a primop, *after* substition (which may reveal more args,
-notably for @CCall@s).
-
-\begin{code}
-primOpUsgTys :: PrimOp -- this primop
- -> [Type] -- instantiated at these (tau) types
- -> ([Type],Type) -- requires args of these (sigma) types,
- -- and returns this (sigma) type
-
-primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
- s = mkTyVarSubst tyvs tys
- (ty1us,rty1u) = splitFunTys (substTy s rtyu)
- -- substitution may reveal more args
- in ((map (substTy s) ty0us) ++ ty1us,
- rty1u)
-
-
-END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
-\end{code}
-
-======================================================================
-
-EOF
projects / ghc-hetmet.git / commitdiff