import UConSet
import CoreSyn
+import CoreFVs ( mustHaveLocalBinding )
+import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( UsageAnn(..),
applyTy, applyTys,
splitUsForAllTys, substUsTy,
mkFunTy, mkForAllTy )
import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
-import DataCon ( dataConType )
-import Const ( Con(..), Literal(..), literalType )
+import Literal ( Literal(..), literalType )
import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
import IdInfo ( setLBVarInfo, LBVarInfo(..) )
-import Id ( idMustBeINLINEd, isExportedId )
-import Name ( isLocallyDefined )
+import Id ( isExportedId )
import VarEnv
import VarSet
import UniqSupply ( UniqSupply, UniqSM,
import Outputable
import Maybes ( expectJust )
import List ( unzip4 )
-import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting )
+import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting, opt_UsageSPOn )
+import CoreLint ( beginPass, endPass )
import ErrUtils ( doIfSet, dumpIfSet )
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
~~~~~~~~~~~~~~~~~~~
\begin{code}
doUsageSPInf :: UniqSupply
-> [CoreBind]
+ -> RuleBase
-> IO [CoreBind]
-doUsageSPInf us binds = do
- let binds1 = doUnAnnotBinds binds
-
- dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
- pprCoreBindings binds1
-
- let ((binds2,ucs,_),_)
- = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
-
- dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
- pprCoreBindings binds2
+doUsageSPInf us binds local_rules
+ | not opt_UsageSPOn
+ = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
+ return binds
+ }
+
+ | otherwise
+ = do
+ let binds1 = doUnAnnotBinds binds
- let ms = solveUCS ucs
- s = case ms of
- Just s -> s
- Nothing -> panic "doUsageSPInf: insol. conset!"
- binds3 = appUSubstBinds s binds2
+ beginPass "UsageSPInf"
- doIfSet opt_DoUSPLinting $
- do doLintUSPAnnotsBinds binds3 -- lint check 1
- doLintUSPConstBinds binds3 -- lint check 2 (force solution)
- doCheckIfWorseUSP binds binds3 -- check for worsening of usages
-
- dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
- pprCoreBindings binds3
+ dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
+ pprCoreBindings binds1
- return binds3
+ let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
+
+ 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
+
+ doIfSet opt_DoUSPLinting $
+ do doLintUSPAnnotsBinds binds3 -- lint check 1
+ doLintUSPConstBinds binds3 -- lint check 2 (force solution)
+ doCheckIfWorseUSP binds binds3 -- check for worsening of usages
+
+ endPass "UsageSPInf" opt_D_dump_usagesp binds3
+
+ return binds3
\end{code}
======================================================================
= panic "usgInfCE: unexpected TyVar"
| otherwise
= do v' <- instVar (lookupVar ve v)
- ASSERT( isUsgTy (varType v' {-'cpp-}) )
- return (Var v',
- varType v',
- emptyUConSet,
- unitMS v')
-
-usgInfCE ve e0@(Con (Literal lit) args)
- = ASSERT( null args )
- do u1 <- newVarUSMM (Left e0)
+ 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)
-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
eyhf3s <- mapM (usgInfCE ve) e1s
let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
h4s = zipWith usgSubTy y3us y2us
- ASSERT( isUsgTy y2u )
- return (Con con (map Type y1s ++ e3s),
- y2u,
- unionUCSs (h3s ++ h4s),
- foldl plusMS emptyMS f3s)
+ return $ ASSERT( isUsgTy y2u )
+ (Con con (map Type y1s ++ e3s),
+ y2u,
+ 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
(y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
(eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
let h4 = usgSubTy yb1u y2u
- ASSERT( isUsgTy y3u )
- return (App ea1 eb1,
- y3u,
- unionUCSs [ha1,hb1,h4],
- fa1 `plusMS` fb1)
+ 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
= do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
(e2,y2u,h2,f2) <- usgInfCE ve1 e0
let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
- ASSERT( isUsgTy y2u )
- return (Let b1s e2,
- y2u,
- unionUCSs [h1,h2,h3],
- fa1 `plusMS` (f2 `delsFromMS` v1s))
+ 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)
(e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
let h4 = usgEqTy y2u y1u -- **! why not subty?
h5 = occChkUConSet v1 f3
- ASSERT( isUsgTy y3u )
- return (Case e2 v1 [(DEFAULT,[],e3)],
- y3u,
- unionUCSs [h2,h3,h4,h5],
- f2 `plusMS` (f3 `delFromMS` v1))
+ 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)
h6s = zipWith occChksUConSet v2ss f4s
f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
- ASSERT( isUsgTy y5u )
- return (Case e2 v2 (zip3 cs v2ss e4s),
- y5u,
- unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
- f2 `plusMS` (f4 `delFromMS` 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
--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,
projects / ghc-hetmet.git / blobdiff