[project @ 2000-03-23 17:45:17 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 160dbc6..60faf60 100644 (file)
--- a/ghc/compiler/usageSP/UsageSPInf.lhs
+++ b/ghc/compiler/usageSP/UsageSPInf.lhs
@@ -26,11 +26,10 @@ import Type             ( UsageAnn(..),
                           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 Id               ( mayHaveNoBinding, isExportedId )
 import Name             ( isLocallyDefined )
 import VarEnv
 import VarSet
@@ -46,6 +45,10 @@ import PprCore          ( pprCoreBindings )
 
 ======================================================================
 
+-- **!  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
 ~~~~~~~~~~~~~~~~~~~
 
@@ -212,23 +215,22 @@ usgInfCE ve e0@(Var v) | isTyVar v
   = 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
@@ -242,13 +244,13 @@ usgInfCE ve e0@(Con con 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)
@@ -256,6 +258,8 @@ usgInfCE ve e0@(Con con args)
                              -- 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
@@ -272,11 +276,11 @@ usgInfCE ve (App ea eb)
            (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
@@ -308,11 +312,11 @@ 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)
-       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)
@@ -321,11 +325,11 @@ usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
        (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)
@@ -347,11 +351,11 @@ usgInfCE ve e0@(Case e1 v1 alts)
            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
@@ -390,7 +394,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) || (idMustBeINLINEd v) )
+                   Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) )
                               ASSERT( isUsgTy (varType v) )
                               v
 
@@ -419,7 +423,7 @@ usgClos :: VarEnv Var        -- environment to close with respect to
         -> (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,