Commit e03c0dd3 authored by lewie's avatar lewie
Browse files

[project @ 1999-12-06 22:52:26 by lewie]

Fixed a FunDep leak in tcSimplifyToDicts (they weren't being filtered out),
and fixed bug in instance improvement (matching wasn't being done correctly
for polymorphic instances).
parent 0e0bde9e
......@@ -22,7 +22,7 @@ import BasicTypes ( RecFlag(..) )
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, instOverloadedFun, newDicts, instToId )
newMethod, instOverloadedFun, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
......
......@@ -3,9 +3,6 @@ module TcImprove ( tcImprove ) where
#include "HsVersions.h"
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
import Type ( tyVarsOfTypes )
import Class ( classInstEnv, classExtraBigSig )
import Unify ( matchTys )
......@@ -15,7 +12,9 @@ import TcType ( zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
import Inst ( Inst, LookupInstResult(..),
lookupInst, isDict, getDictClassTys, getFunDepsOfLIE,
zonkLIE {- for debugging -} )
zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
-- 4.02 doesn't "see" it soon enough
import VarSet ( emptyVarSet )
import VarEnv ( emptyVarEnv )
import FunDeps ( instantiateFdClassTys )
......@@ -27,23 +26,43 @@ import List ( elemIndex )
Improvement goes here.
\begin{code}
tcImprove lie = iterImprove (getFunDepsOfLIE lie)
tcImprove lie =
if null cfdss then
returnTc ()
else
-- zonkCfdss cfdss `thenTc` \ cfdss' ->
-- pprTrace "tcI" (ppr cfdss') $
iterImprove cfdss
where cfdss = getFunDepsOfLIE lie
iterImprove [] = returnTc ()
iterImprove cfdss
= instImprove cfdss `thenTc` \ change1 ->
= -- zonkCfdss cfdss `thenTc` \ cfdss' ->
-- pprTrace "iterI" (ppr cfdss') $
instImprove cfdss `thenTc` \ change1 ->
selfImprove pairImprove cfdss `thenTc` \ change2 ->
if change1 || change2 then
iterImprove cfdss
else
returnTc ()
-- ZZ debugging...
zonkCfdss ((c, fds) : cfdss)
= zonkFunDeps fds `thenTc` \ fds' ->
zonkCfdss cfdss `thenTc` \ cfdss' ->
returnTc ((c, fds') : cfdss')
zonkCfdss [] = returnTc []
instImprove (cfds@(clas, fds) : cfdss)
= instImprove1 cfds ins
= instImprove1 cfds ins `thenTc` \ changed ->
instImprove cfdss `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
where ins = classInstEnv clas
instImprove [] = returnTc False
instImprove1 cfds@(clas, fds1) ((free, ts, _) : ins)
= checkFds fds1 free fds2 `thenTc` \ changed ->
instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
= -- pprTrace "iI1" (ppr (free, ts, i)) $
checkFds fds1 free fds2 `thenTc` \ changed ->
instImprove1 cfds ins `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
where fds2 = instantiateFdClassTys clas ts
......@@ -52,7 +71,7 @@ instImprove1 _ _ = returnTc False
selfImprove f [] = returnTc False
selfImprove f (cfds : cfdss)
= mapTc (f cfds) cfdss `thenTc` \ changes ->
orTc changes `thenTc` \ changed ->
anyTc changes `thenTc` \ changed ->
selfImprove f cfdss `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
......@@ -76,79 +95,35 @@ checkFd (t_x, t_y) free (s_x, s_y)
case msubst of
Just subst ->
let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in
zonkMatchTys t_y free s_y `thenTc` \ msubst2 ->
case msubst2 of
Just _ ->
-- they're the same, nothing changes
returnTc False
Nothing ->
unifyTauTyLists t_y s_y' `thenTc_`
-- if we get here, something must have unified
returnTc True
zonkEqTys t_y s_y' `thenTc` \ eq ->
if eq then
-- they're the same, nothing changes...
returnTc False
else
unifyTauTyLists t_y s_y' `thenTc_`
-- if we get here, something must have unified
returnTc True
Nothing ->
returnTc False
zonkEqTys ts1 ts2
= mapTc zonkTcType ts1 `thenTc` \ ts1' ->
mapTc zonkTcType ts2 `thenTc` \ ts2' ->
returnTc (ts1' == ts2')
zonkMatchTys ts1 free ts2
= mapTc zonkTcType ts1 `thenTc` \ ts1' ->
mapTc zonkTcType ts2 `thenTc` \ ts2' ->
--returnTc (ts1' == ts2')
-- pprTrace "zMT" (ppr (ts1', free, ts2')) $
case matchTys free ts2' ts1' of
Just (subst, []) -> returnTc (Just subst)
Just (subst, []) -> -- pprTrace "zMT match!" empty $
returnTc (Just subst)
Nothing -> returnTc Nothing
{-
instImprove clas fds =
pprTrace "class inst env" (ppr (clas, classInstEnv clas)) $
zonkFunDeps fds `thenTc` \ fds' ->
pprTrace "lIEFDs" (ppr (clas, fds')) $
case lookupInstEnvFDs clas fds' of
Nothing -> returnTc ()
Just (t_y, s_y) ->
pprTrace "lIEFDs result" (ppr (t_y, s_y)) $
unifyTauTyLists t_y s_y
lookupInstEnvFDs clas fds
= find env
where
env = classInstEnv clas
(ctvs, fds, _, _, _, _) = classExtraBigSig clas
find [] = Nothing
find ((tpl_tyvars, tpl, val) : rest)
= let tplx = concatMap (\us -> thingy tpl us ctvs) (map fst fds)
tply = concatMap (\vs -> thingy tpl vs ctvs) (map snd fds)
in
case matchTys tpl_tyvars tplx tysx of
Nothing -> find rest
Just (tenv, leftovers) ->
let subst = mkSubst (tyVarsOfTypes tys) tenv
in
-- this is the list of things that
-- need to be unified
Just (map (substTy subst) tply, tysy)
tysx = concatMap (\us -> thingy tys us ctvs) (map fst fds)
tysy = concatMap (\vs -> thingy tys vs ctvs) (map snd fds)
thingy f us ctvs
= map (f !!) is
where is = map (\u -> let Just i = elemIndex u ctvs in i) us
-}
{-
= let (clas, tys) = getDictClassTys dict
in
-- first, do instance-based improvement
instImprove clas tys `thenTc_`
-- OK, now do pairwise stuff
mapTc (f clas tys) dicts `thenTc` \ changes ->
foldrTc (\a b -> returnTc (a || b)) False changes `thenTc` \ changed ->
allDictPairs f dicts `thenTc` \ rest_changed ->
returnTc (changed || rest_changed)
-}
\end{code}
Utilities:
A monadic version of the standard Prelude `or' function.
\begin{code}
orTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
\end{code}
......@@ -17,8 +17,7 @@ import TcHsSyn ( TcPat, TcId )
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, LIE,
newMethod, newOverloadedLit,
newDicts, instToIdBndr
newMethod, newOverloadedLit, newDicts
)
import Name ( Name, getOccName, getSrcLoc )
import FieldLabel ( fieldLabelName )
......
......@@ -328,7 +328,8 @@ tcSimplifyToDicts wanted_lie
ASSERT( null frees )
returnTc (mkLIE irreds, binds)
where
wanteds = bagToList wanted_lie
-- see comment on wanteds in tcSimplify
wanteds = filter notFunDep (bagToList wanted_lie)
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = DontReduce
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment