[project @ 2001-03-08 12:07:38 by simonpj]

[ghc-hetmet.git] / ghc / compiler / usageSP / UsageSPInf.lhs

diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs
index ee9be6e..8be6654 100644 (file)
--- a/ghc/compiler/usageSP/UsageSPInf.lhs
+++ b/ghc/compiler/usageSP/UsageSPInf.lhs
@@ -18,20 +18,16 @@ import UsageSPLint
 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 PprType         ( {- instance Outputable Type -} )
 import TyCon            ( tyConArgVrcs_maybe, isFunTyCon )
 import Literal          ( Literal(..), literalType )
-import Var              ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
+import Var              ( Var, varType, setVarType, modifyIdInfo )
 import IdInfo           ( setLBVarInfo, LBVarInfo(..) )
-import Id               ( mayHaveNoBinding, isExportedId )
-import Name             ( isLocallyDefined )
+import Id               ( isExportedId )
 import VarEnv
 import VarSet
 import UniqSupply       ( UniqSupply, UniqSM,
@@ -39,8 +35,9 @@ import UniqSupply       ( UniqSupply, UniqSM,
 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}
 
@@ -88,37 +85,52 @@ The inference is done over a set of @CoreBind@s, and inside the IO
 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
+
+   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.
 
-                           let ((binds2,ucs,_),_)
-                                      = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
 
-                           dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
-                             pprCoreBindings binds2
+  | 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
+       showPass dflags "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_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
+                             pprCoreBindings binds1
 
-                           dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
-                             pprCoreBindings binds3
+        let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
 
-                           return binds3
+        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}
 
 ======================================================================
@@ -339,7 +351,7 @@ usgInfCE ve e0@(Case e1 v1 alts)
        (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
@@ -395,7 +407,7 @@ lookupVar :: VarEnv Var -> Var -> Var
 --lookupVar ve v = error "lookupVar unimplemented"
 lookupVar ve v = case lookupVarEnv ve v of
                    Just v' -> v'
-                   Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) )
+                   Nothing -> ASSERT( not (mustHaveLocalBinding v) )
                               ASSERT( isUsgTy (varType v) )
                               v
 
@@ -651,6 +663,9 @@ 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}
 
 ======================================================================