import UConSet
import CoreSyn
+import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( UsageAnn(..),
- applyTy, applyTys,
- splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
- mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
- splitUsForAllTys, substUsTy,
+import Type ( applyTy, applyTys,
+ splitFunTy_maybe, splitFunTys, splitTyConApp,
mkFunTy, mkForAllTy )
import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
-import DataCon ( dataConType )
-import Const ( Con(..), Literal(..), literalType )
-import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
+import Literal ( Literal(..), literalType )
+import Var ( Var, varType, setVarType, modifyIdInfo )
import IdInfo ( setLBVarInfo, LBVarInfo(..) )
-import Id ( idMustBeINLINEd, isExportedId )
-import Name ( isLocallyDefined )
+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 ( opt_D_dump_usagesp, opt_DoUSPLinting )
-import ErrUtils ( doIfSet, dumpIfSet )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn )
+import CoreLint ( showPass, endPass )
+import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn )
import PprCore ( pprCoreBindings )
\end{code}
monad.
\begin{code}
-doUsageSPInf :: UniqSupply
+doUsageSPInf :: DynFlags
+ -> UniqSupply
-> [CoreBind]
-> IO [CoreBind]
-doUsageSPInf us binds = do
- let binds1 = doUnAnnotBinds binds
+doUsageSPInf dflags us binds
+ | not opt_UsageSPOn
+ = do { printDump (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
+ return binds
+ }
- dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
- pprCoreBindings binds1
+{- ENTIRE PASS COMMENTED OUT FOR NOW -- KSW 2000-10-13
- let ((binds2,ucs,_),_)
- = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
+ 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.
- dumpIfSet 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
+ | otherwise
+ = do
+ let binds1 = doUnAnnotBinds binds
- doIfSet opt_DoUSPLinting $
- do doLintUSPAnnotsBinds binds3 -- lint check 1
- doLintUSPConstBinds binds3 -- lint check 2 (force solution)
- doCheckIfWorseUSP binds binds3 -- check for worsening of usages
+ showPass dflags "UsageSPInf"
- dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
- pprCoreBindings binds3
+ dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
+ pprCoreBindings binds1
- return binds3
+ 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}
======================================================================
emptyUConSet,
unitMS v')
-usgInfCE ve e0@(Con (Literal lit) args)
- = ASSERT( null args )
- do u1 <- newVarUSMM (Left e0)
+usgInfCE ve e0@(Lit lit)
+ = do u1 <- newVarUSMM (Left e0)
return (e0,
mkUsgTy u1 (literalType lit),
emptyUConSet,
emptyMS)
-usgInfCE ve (Con DEFAULT _)
- = panic "usgInfCE: DEFAULT"
-
+{- ------------------------------------
+ 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
unionUCSs (h3s ++ h4s),
foldl plusMS emptyMS f3s)
- where dataConTys c u y1s
+ 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)
-- 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
(e2,y2u,h2,f2) <- usgInfCE ve e1
let h3 = usgEqTy y2u y1u -- **! why not subty?
(u2,y2) = splitUsgTy y2u
- (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
+ (tc,y2s) = splitTyConApp y2
(cs,v1ss,es) = unzip3 alts
v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
v1ss
--lookupVar ve v = error "lookupVar unimplemented"
lookupVar ve v = case lookupVarEnv ve v of
Just v' -> v'
- Nothing -> ASSERT( not (isLocallyDefined v) || (idMustBeINLINEd v) )
+ Nothing -> ASSERT( not (mustHaveLocalBinding v) )
ASSERT( isUsgTy (varType v) )
v
-> (Type, -- closed type (rho)
UConSet) -- residual constraint set
-usgClos _ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
+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,
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)&&(length tys > 1)) )
+ 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
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}
======================================================================