ghc/compiler/typecheck/TcImprove.lhs

   1 \begin{code}
   2 module TcImprove ( tcImprove ) where
   3
   4 #include "HsVersions.h"
   5
   6 import Type             ( tyVarsOfTypes )
   7 import Class            ( classInstEnv, classExtraBigSig )
   8 import Unify            ( matchTys )
   9 import Subst            ( mkSubst, substTy )
  10 import TcMonad
  11 import TcType           ( zonkTcType, zonkTcTypes )
  12 import TcUnify          ( unifyTauTyLists )
  13 import Inst             ( Inst, LookupInstResult(..),
  14                           lookupInst, isDict, getDictClassTys, getFunDeps,
  15                           zonkLIE {- for debugging -} )
  16 import VarSet           ( emptyVarSet )
  17 import VarEnv           ( emptyVarEnv )
  18 import FunDeps          ( instantiateFdClassTys )
  19 import Bag              ( bagToList )
  20 import Outputable
  21 import List             ( elemIndex )
  22 import Maybe            ( catMaybes )
  23 \end{code}
  24
  25 Improvement goes here.
  26
  27 \begin{code}
  28 tcImprove lie
  29   = let cfdss = catMaybes (map getFunDeps (bagToList lie)) in
  30     iterImprove cfdss
  31
  32 iterImprove cfdss
  33   = instImprove cfdss                   `thenTc` \ change1 ->
  34     selfImprove pairImprove cfdss       `thenTc` \ change2 ->
  35     if change1 || change2 then
  36         iterImprove cfdss
  37     else
  38         returnTc ()
  39
  40 instImprove (cfds@(clas, fds) : cfdss)
  41   = instImprove1 cfds ins
  42   where ins = classInstEnv clas
  43 instImprove [] = returnTc False
  44
  45 instImprove1 cfds@(clas, fds1) ((free, ts, _) : ins)
  46   = checkFds fds1 free fds2     `thenTc` \ changed ->
  47     instImprove1 cfds ins       `thenTc` \ rest_changed ->
  48     returnTc (changed || rest_changed)
  49   where fds2 = instantiateFdClassTys clas ts
  50 instImprove1 _ _ = returnTc False
  51
  52 selfImprove f [] = returnTc False
  53 selfImprove f (cfds : cfdss)
  54   = mapTc (f cfds) cfdss        `thenTc` \ changes ->
  55     orTc changes                `thenTc` \ changed ->
  56     selfImprove f cfdss         `thenTc` \ rest_changed ->
  57     returnTc (changed || rest_changed)
  58
  59 pairImprove (clas1, fds1) (clas2, fds2)
  60   = if clas1 == clas2 then
  61         checkFds fds1 emptyVarSet fds2
  62     else
  63         returnTc False
  64
  65 checkFds [] free [] = returnTc False
  66 checkFds (fd1 : fd1s) free (fd2 : fd2s) =
  67     checkFd fd1 free fd2        `thenTc` \ change ->
  68     checkFds fd1s free fd2s     `thenTc` \ changes ->
  69     returnTc (change || changes)
  70 --checkFds _ _ = returnTc False
  71
  72 checkFd (t_x, t_y) free (s_x, s_y)
  73   -- we need to zonk each time because unification
  74   -- may happen at any time
  75   = zonkMatchTys t_x free s_x `thenTc` \ msubst ->
  76     case msubst of
  77       Just subst ->
  78         let s_y' = map (substTy (mkSubst emptyVarEnv subst)) s_y in
  79             zonkMatchTys t_y free s_y `thenTc` \ msubst2 ->
  80                 case msubst2 of
  81                   Just _ ->
  82                     -- they're the same, nothing changes
  83                     returnTc False
  84                   Nothing ->
  85                     unifyTauTyLists t_y s_y' `thenTc_`
  86                     -- if we get here, something must have unified
  87                     returnTc True
  88       Nothing ->
  89         returnTc False
  90
  91 zonkMatchTys ts1 free ts2
  92   = mapTc zonkTcType ts1 `thenTc` \ ts1' ->
  93     mapTc zonkTcType ts2 `thenTc` \ ts2' ->
  94     --returnTc (ts1' == ts2')
  95     case matchTys free ts2' ts1' of
  96       Just (subst, []) -> returnTc (Just subst)
  97       Nothing -> returnTc Nothing
  98
  99 {-
 100 instImprove clas fds =
 101     pprTrace "class inst env" (ppr (clas, classInstEnv clas)) $
 102     zonkFunDeps fds `thenTc` \ fds' ->
 103     pprTrace "lIEFDs" (ppr (clas, fds')) $
 104     case lookupInstEnvFDs clas fds' of
 105       Nothing -> returnTc ()
 106       Just (t_y, s_y) ->
 107         pprTrace "lIEFDs result" (ppr (t_y, s_y)) $
 108         unifyTauTyLists t_y s_y
 109
 110 lookupInstEnvFDs clas fds
 111   = find env
 112   where
 113     env = classInstEnv clas
 114     (ctvs, fds, _, _, _, _) = classExtraBigSig clas
 115     find [] = Nothing
 116     find ((tpl_tyvars, tpl, val) : rest)
 117       = let tplx = concatMap (\us -> thingy tpl us ctvs) (map fst fds)
 118             tply = concatMap (\vs -> thingy tpl vs ctvs) (map snd fds)
 119         in
 120             case matchTys tpl_tyvars tplx tysx of
 121               Nothing -> find rest
 122               Just (tenv, leftovers) ->
 123                 let subst = mkSubst (tyVarsOfTypes tys) tenv
 124                 in
 125                     -- this is the list of things that
 126                     -- need to be unified
 127                     Just (map (substTy subst) tply, tysy)
 128     tysx = concatMap (\us -> thingy tys us ctvs) (map fst fds)
 129     tysy = concatMap (\vs -> thingy tys vs ctvs) (map snd fds)
 130     thingy f us ctvs
 131       = map (f !!) is
 132         where is = map (\u -> let Just i = elemIndex u ctvs in i) us
 133 -}
 134
 135 {-
 136   = let (clas, tys) = getDictClassTys dict
 137     in
 138         -- first, do instance-based improvement
 139         instImprove clas tys `thenTc_`
 140         -- OK, now do pairwise stuff
 141         mapTc (f clas tys) dicts `thenTc` \ changes ->
 142         foldrTc (\a b -> returnTc (a || b)) False changes `thenTc` \ changed ->
 143         allDictPairs f dicts `thenTc` \ rest_changed ->
 144         returnTc (changed || rest_changed)
 145 -}
 146
 147 \end{code}
 148
 149 Utilities:
 150
 151 A monadic version of the standard Prelude `or' function.
 152 \begin{code}
 153 orTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
 154 \end{code}