[project @ 1998-04-10 15:00:19 by simonpj]

Fix TcExpr loop; and -prof fail on specialisation

diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 04ae01a..fb6b23c 100644 (file)
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -96,14 +96,7 @@ lookupSpecEnv doc (SpecEnv alist) key
   where
     find [] = Nothing
     find ((tpl, val) : rest)
-      = 
-#ifdef DEBUG
-       if length tpl > length key then
-               pprTrace "lookupSpecEnv" (doc <+> ppr tpl <+> ppr key) $
-               Nothing
-       else
-#endif
-       case matchTys tpl key of
+      = case matchTys tpl key of
          Nothing                 -> find rest
          Just (subst, leftovers) -> ASSERT( null leftovers )
                                     Just (subst, val)

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index e550294..6041340 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -721,7 +721,13 @@ specBind (NonRec bndr rhs) body_uds
     specDefn (calls body_uds) (bndr,rhs)       `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
     let
        (all_uds, (dict_binds, dump_calls)) 
-               = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds)
+               = splitUDs [ValBinder bndr]
+                          (body_uds `plusUDs` spec_uds)
+                       -- It's important that the `plusUDs` is this way round,
+                       -- because body_uds may bind dictionaries that are
+                       -- used in the calls passed to specDefn.  So the
+                       -- dictionary bindings in spec_uds may mention 
+                       -- dictionaries bound in body_uds.
 
         -- If we make specialisations then we Rec the whole lot together
         -- If not, leave it as a NonRec
@@ -736,8 +742,12 @@ specBind (Rec pairs) body_uds
        (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
        spec_defns = concat spec_defns_s
        spec_uds   = plusUDList spec_uds_s
+
        (all_uds, (dict_binds, dump_calls)) 
-               = splitUDs (map (ValBinder . fst) pairs) (spec_uds `plusUDs` body_uds)
+               = splitUDs (map (ValBinder . fst) pairs)
+                          (body_uds `plusUDs` spec_uds)
+                       -- See notes for non-rec case
+
         new_bind = Rec (spec_defns ++ pairs')
     in
     returnSM ( new_bind : mkDictBinds dict_binds, all_uds )

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 501eed8..0e719a9 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -650,7 +650,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
        tcMonoExpr expr sig_tc_ty
 
    else        -- Signature is polymorphic
-       tcPolyExpr in_expr sig_tc_ty            `thenTc` \ (_, _, expr, expr_ty, lie) ->
+       tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 
            -- Now match the signature type with res_ty.
            -- We must not do this earlier, because res_ty might well

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index a68c59a..e7c1d38 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -430,14 +430,13 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
                -- emit an error message.  This in turn means that we don't
                -- mention the constructor, which doesn't exist for CCallable, CReturnable
                -- Hardly beautiful, but only three extra lines.
-          HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
-                (HsLitOut (HsString msg) stringTy)
+           HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
+                 (HsLitOut (HsString msg) stringTy)
 
          | otherwise   -- The common case
-         = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
-                              (map HsVar (sc_dict_ids ++ meth_ids))
+         = HsCon dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
                -- We don't produce a binding for the dict_constr; instead we
-               -- rely on the simplifier to unfold this saturated application
+               -- just generate the saturated constructor directly
          where
            msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index cdfb8f5..7ed38a5 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -155,6 +155,9 @@ tcModule rn_name_supply
        
        -- Create any necessary record selector Ids and their bindings
        -- "Necessary" includes data and newtype declarations
+       -- We don't create bindings for dictionary constructors;
+       -- they are always fully applied, and the bindings are just there
+       -- to support partial applications
        let
            tycons       = getEnv_TyCons env
            classes      = getEnv_Classes env

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 3273b60..5b73eeb 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -659,7 +659,7 @@ match ty1       (SynTy _ ty2) k = match ty1 ty2 k
 match _ _ _ = \s -> Nothing
 
 match_list []         tys2       k = \s -> k (s, tys2)
-match_list (ty1:tys1) []         k = panic "match_list"
+match_list (ty1:tys1) []         k = \s -> Nothing     -- Not enough arg tys => failure
 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
 \end{code}