From 51d9f5df468fdc09ea97d116c71cd7b95fcfe0fe Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 10 Apr 1998 15:00:44 +0000
Subject: [PATCH] [project @ 1998-04-10 15:00:19 by simonpj] Fix TcExpr loop;
and -prof fail on specialisation
---
ghc/compiler/specialise/SpecEnv.lhs | 9 +--------
ghc/compiler/specialise/Specialise.lhs | 14 ++++++++++++--
ghc/compiler/typecheck/TcExpr.lhs | 2 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 9 ++++-----
ghc/compiler/typecheck/TcModule.lhs | 3 +++
ghc/compiler/types/Type.lhs | 2 +-
6 files changed, 22 insertions(+), 17 deletions(-)
diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 04ae01acbff5..fb6b23c2e5c6 100644
--- 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 e550294fbb71..604134009ccf 100644
--- 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 501eed81e737..0e719a9e5ff2 100644
--- 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 a68c59a19acf..e7c1d38ec592 100644
--- 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 cdfb8f5a1420..7ed38a5964e4 100644
--- 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 3273b6081aed..5b73eeb0120a 100644
--- 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}
--
GitLab