[project @ 2000-10-17 10:27:58 by sewardj]

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

diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs
index d0f062e..0cdf16f 100644 (file)
--- a/ghc/compiler/usageSP/UsageSPInf.lhs
+++ b/ghc/compiler/usageSP/UsageSPInf.lhs
@@ -18,6 +18,7 @@ import UsageSPLint
 import UConSet
 
 import CoreSyn
+import CoreFVs         ( mustHaveLocalBinding )
 import Rules            ( RuleBase )
 import TypeRep          ( Type(..), TyNote(..) ) -- friend
 import Type             ( UsageAnn(..),
@@ -26,13 +27,11 @@ import Type             ( UsageAnn(..),
                           mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
                           splitUsForAllTys, substUsTy,
                           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 IdInfo           ( setLBVarInfo, LBVarInfo(..) )
-import Id               ( mayHaveNoBinding, isExportedId )
-import Name             ( isLocallyDefined )
+import Id               ( isExportedId )
 import VarEnv
 import VarSet
 import UniqSupply       ( UniqSupply, UniqSM,
@@ -40,7 +39,8 @@ 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}
@@ -92,36 +92,42 @@ monad.
 doUsageSPInf :: UniqSupply
              -> [CoreBind]
              -> RuleBase
-             -> IO ([CoreBind], Maybe RuleBase)
+             -> IO [CoreBind]
 
 doUsageSPInf us binds local_rules
-                      = do
-                           let binds1      = doUnAnnotBinds binds
-
-                           dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
+  | not opt_UsageSPOn
+  = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
+        return binds
+    }
+      
+  | otherwise
+  = do
+        let binds1 = doUnAnnotBinds binds
+
+       beginPass "UsageSPInf"
+
+        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
-
-                           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
-
-                           dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
-                             pprCoreBindings binds3
+        let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
 
-                           return (binds3, Nothing)
+        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}
 
 ======================================================================
@@ -398,7 +404,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