ghc/compiler/specialise/SpecEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SpecEnv]{Specialisation info about an @Id@}
   5
   6 \begin{code}
   7 module SpecEnv (
   8         SpecEnv,
   9         emptySpecEnv, isEmptySpecEnv,
  10         specEnvValues, specEnvToList, specEnvFromList,
  11         addToSpecEnv, lookupSpecEnv, substSpecEnv
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import Var              ( TyVar )
  17 import VarEnv
  18 import VarSet
  19 import Type             ( Type, fullSubstTy, substTyVar )
  20 import Unify            ( unifyTyListsX, matchTys )
  21 import Outputable
  22 import Maybes
  23 \end{code}
  24
  25
  26
  27 %************************************************************************
  28 %*                                                                      *
  29 \section{SpecEnv}
  30 %*                                                                      *
  31 %************************************************************************
  32
  33 \begin{code}
  34 data SpecEnv value
  35   = EmptySE
  36   | SpecEnv [([TyVar],  -- Really a set, but invariably small,
  37                         -- so kept as a list
  38               [Type],
  39               value)]
  40
  41 specEnvValues :: SpecEnv value -> [value]
  42 specEnvValues EmptySE         = []
  43 specEnvValues (SpecEnv alist) = [val | (_,_,val) <- alist]
  44
  45 specEnvToList :: SpecEnv value -> [([TyVar], [Type], value)]
  46 specEnvToList EmptySE         = []
  47 specEnvToList (SpecEnv alist) = alist
  48
  49 specEnvFromList :: [([TyVar], [Type], value)] -> SpecEnv value
  50         -- Assumes the list is in appropriate order
  51 specEnvFromList []    = EmptySE
  52 specEnvFromList alist = SpecEnv alist
  53 \end{code}
  54
  55 In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
  56
  57 In others, overlap is permitted, but only in such a way that one can make
  58 a unique choice when looking up.  That is, overlap is only permitted if
  59 one template matches the other, or vice versa.  So this is ok:
  60
  61   [a]  [Int]
  62
  63 but this is not
  64
  65   (Int,a)  (b,Int)
  66
  67 If overlap is permitted, the list is kept most specific first, so that
  68 the first lookup is the right choice.
  69
  70
  71 For now we just use association lists.
  72
  73 \begin{code}
  74 emptySpecEnv :: SpecEnv a
  75 emptySpecEnv = EmptySE
  76
  77 isEmptySpecEnv EmptySE = True
  78 isEmptySpecEnv _       = False
  79 \end{code}
  80
  81 @lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match.  Since the env is kept
  82 ordered, the first match must be the only one.
  83 The thing we are looking up can have an
  84 arbitrary "flexi" part.
  85
  86 \begin{code}
  87 lookupSpecEnv :: SDoc           -- For error report
  88               -> SpecEnv value  -- The envt
  89               -> [Type]         -- Key
  90               -> Maybe (TyVarEnv Type, value)
  91
  92 lookupSpecEnv doc EmptySE key = Nothing
  93 lookupSpecEnv doc (SpecEnv alist) key
  94   = find alist
  95   where
  96     find [] = Nothing
  97     find ((tpl_tyvars, tpl, val) : rest)
  98       = case matchTys tpl_tyvars tpl key of
  99           Nothing                 -> find rest
 100           Just (subst, leftovers) -> ASSERT( null leftovers )
 101                                      Just (subst, val)
 102 \end{code}
 103
 104 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
 105
 106 A boolean flag controls overlap reporting.
 107
 108 True => overlap is permitted, but only if one template matches the other;
 109         not if they unify but neither is
 110
 111 \begin{code}
 112 addToSpecEnv :: Bool                            -- True <=> overlap permitted
 113              -> SpecEnv value                   -- Envt
 114              -> [TyVar] -> [Type] -> value      -- New item
 115              -> MaybeErr (SpecEnv value)        -- Success...
 116                           ([Type], value)       -- Failure: Offending overlap
 117
 118 addToSpecEnv overlap_ok spec_env ins_tvs ins_tys value
 119   = case spec_env of
 120        EmptySE       -> returnMaB (SpecEnv [ins_item])
 121        SpecEnv alist -> insert alist    `thenMaB` \ alist' ->
 122                         returnMaB (SpecEnv alist')
 123   where
 124     ins_item = (ins_tvs, ins_tys, value)
 125
 126     insert [] = returnMaB [ins_item]
 127     insert alist@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
 128
 129         -- FAIL if:
 130         -- (a) they are the same, or
 131         -- (b) they unify, and any sort of overlap is prohibited,
 132         -- (c) they unify but neither is more specific than t'other
 133       |  identical
 134       || (unifiable && not overlap_ok)
 135       || (unifiable && not (ins_item_more_specific || cur_item_more_specific))
 136       =  failMaB (tpl_tys, val)
 137
 138         -- New item is an instance of current item, so drop it here
 139       | ins_item_more_specific  = returnMaB (ins_item : alist)
 140
 141         -- Otherwise carry on
 142       | otherwise  = insert rest     `thenMaB` \ rest' ->
 143                      returnMaB (cur_item : rest')
 144       where
 145         unifiable = maybeToBool (unifyTyListsX (ins_tvs ++ tpl_tvs) tpl_tys ins_tys)
 146         ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys)
 147         cur_item_more_specific = maybeToBool (matchTys ins_tvs ins_tys tpl_tys)
 148         identical = ins_item_more_specific && cur_item_more_specific
 149 \end{code}
 150
 151 Finally, during simplification we must apply the current substitution to
 152 the SpecEnv.
 153
 154 \begin{code}
 155 substSpecEnv :: TyVarEnv Type -> IdOrTyVarSet
 156              -> (TyVarEnv Type -> IdOrTyVarSet -> val -> val)
 157              -> SpecEnv val -> SpecEnv val
 158 substSpecEnv ty_subst in_scope val_fn EmptySE = EmptySE
 159 substSpecEnv ty_subst in_scope val_fn (SpecEnv alist)
 160   = SpecEnv (map subst alist)
 161   where
 162     subst (tpl_tyvars, tpl_tys, val)
 163         = (tpl_tyvars',
 164            map (fullSubstTy ty_subst' in_scope') tpl_tys,
 165            val_fn ty_subst' in_scope' val)
 166         where
 167           (ty_subst', in_scope', tpl_tyvars') = go ty_subst in_scope [] tpl_tyvars
 168
 169           go s i acc []       = (s, i, reverse acc)
 170           go s i acc (tv:tvs) = case substTyVar s i tv of
 171                                   (s', i', tv') -> go s' i' (tv' : acc) tvs
 172 \end{code}