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