[project @ 1999-12-03 00:03:06 by lewie]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index a3177a2..55c37dd 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -16,7 +16,7 @@ import HsSyn          ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), Stmt
                          collectMonoBinders, andMonoBindList, andMonoBinds
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn         ( TcHsBinds, TcMonoBinds, TcId, zonkId )
+import TcHsSyn         ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
 import Inst            ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
@@ -27,7 +27,8 @@ import TcEnv          ( tcExtendLocalValEnv,
                          tcLookupTyCon, 
                          tcGetGlobalTyVars, tcExtendGlobalTyVars
                        )
-import TcSimplify      ( tcSimplify, tcSimplifyAndCheck )
+import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
+import TcImprove       ( tcImprove )
 import TcMonoType      ( tcHsType, checkSigTyVars,
                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
@@ -58,6 +59,7 @@ import Bag
 import Util            ( isIn )
 import Maybes          ( maybeToBool )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
+import FiniteMap       ( listToFM, lookupFM )
 import SrcLoc           ( SrcLoc )
 import Outputable
 \end{code}
@@ -249,6 +251,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        -- (must do this before getTyVarsToGen)
     checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs     `thenTc` \ maybe_sig_theta ->   
 
+       -- IMPROVE the LIE
+       -- Force any unifications dictated by functional dependencies.
+       -- Because unification may happen, it's important that this step
+       -- come before:
+       --   - computing vars over which to quantify
+       --   - zonking the generalized type vars
+    tcImprove lie_req `thenTc_`
+
        -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
        -- The tyvars_not_to_gen are free in the environment, and hence
        -- candidates for generalisation, but sometimes the monomorphism
@@ -354,8 +364,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        exports  = zipWith mk_export binder_names zonked_mono_ids
        dict_tys = map idType dicts_bound
 
-       inlines    = mkNameSet [name | InlineSig   name loc <- inline_sigs]
-        no_inlines = mkNameSet [name | NoInlineSig name loc <- inline_sigs]
+       inlines    = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
+        no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
+                              [(name, IMustNotBeINLINEd True  phase) | InlineSig   name phase loc <- inline_sigs, maybeToBool phase])
+               -- "INLINE n foo" means inline foo, but not until at least phase n
+               -- "NOINLINE n foo" means don't inline foo until at least phase n, and even 
+               --                  then only if it is small enough etc.
+               -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
+               -- See comments in CoreUnfold.blackListed for the Authorised Version
 
        mk_export binder_name zonked_mono_id
          = (tyvars, 
@@ -408,8 +424,9 @@ justPatBindings (AndMonoBinds b1 b2) binds =
 justPatBindings other_bind binds = binds
 
 attachNoInlinePrag no_inlines bndr
-  | idName bndr `elemNameSet` no_inlines = bndr `setInlinePragma` IMustNotBeINLINEd
-  | otherwise                           = bndr
+  = case lookupFM no_inlines (idName bndr) of
+       Just prag -> bndr `setInlinePragma` prag
+       Nothing   -> bndr
 \end{code}
 
 Polymorphic recursion
@@ -474,7 +491,7 @@ is doing.
 %*                                                                     *
 %************************************************************************
 
-@getTyVarsToGen@ decides what type variables generalise over.
+@getTyVarsToGen@ decides what type variables to generalise over.
 
 For a "restricted group" -- see the monomorphism restriction
 for a definition -- we bind no dictionaries, and
@@ -837,6 +854,9 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
        -- the spec-pragma-id at the same time
     tcExpr (HsVar name) sig_ty                 `thenTc` \ (spec_expr, spec_lie) ->
 
+       -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
+    tcSimplifyToDicts spec_lie                 `thenTc` \ (spec_lie1, spec_binds) ->
+
        -- Just specialise "f" by building a SpecPragmaId binding
        -- It is the thing that makes sure we don't prematurely 
        -- dead-code-eliminate the binding we are really interested in.
@@ -844,8 +864,8 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
 
        -- Do the rest and combine
     tcSpecSigs sigs                    `thenTc` \ (binds_rest, lie_rest) ->
-    returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id spec_expr,
-             lie_rest   `plusLIE`      spec_lie)
+    returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
+             lie_rest   `plusLIE`      spec_lie1)
 
 tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
 tcSpecSigs []                = returnTc (EmptyMonoBinds, emptyLIE)