ghc/compiler/specialise/SpecEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SpecEnv]{Specialisation info about an @Id@}
   5
   6 \begin{code}
   7 module SpecEnv (
   8         SpecEnv,
   9         emptySpecEnv, isEmptySpecEnv,
  10         specEnvValues, specEnvToList,
  11         addToSpecEnv, lookupSpecEnv, substSpecEnv
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import Type             ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
  17 import TyVar            ( TyVar, GenTyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
  18 import Unify            ( Subst, unifyTyListsX )
  19 import Outputable
  20 import Maybes
  21 import Util             ( assertPanic )
  22 \end{code}
  23
  24
  25
  26 %************************************************************************
  27 %*                                                                      *
  28 \section{SpecEnv}
  29 %*                                                                      *
  30 %************************************************************************
  31
  32 \begin{code}
  33 type TemplateTyVar = GenTyVar Bool
  34 type TemplateType  = GenType Bool
  35       -- The Bool is True for template type variables;
  36       -- that is, ones that can be bound
  37
  38 data SpecEnv value
  39   = EmptySE
  40   | SpecEnv [([TemplateType], value)]
  41
  42 specEnvValues :: SpecEnv value -> [value]
  43 specEnvValues EmptySE         = []
  44 specEnvValues (SpecEnv alist) = map snd alist
  45
  46 specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
  47 specEnvToList EmptySE         = []
  48 specEnvToList (SpecEnv alist)
  49   = map do_item alist
  50   where
  51     do_item (tys, val) = (tyvars, tys, val)
  52                        where
  53                          tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
  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, val) : rest)
  99       = case matchTys 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                           ([TemplateType], value)       -- Failure: Offending overlap
 118
 119 addToSpecEnv overlap_ok spec_env tvs 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_tys, value)
 126     ins_tys  = map (applyToTyVars mk_tv) tys
 127
 128     mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
 129                -- tvs identifies the template variables
 130
 131     insert [] = returnMaB [ins_item]
 132     insert alist@(cur_item@(cur_tys, _) : rest)
 133       | unifiable && not overlap_ok             = failMaB cur_item
 134       | unifiable && ins_item_more_specific     = returnMaB (ins_item : alist)
 135       | unifiable && not cur_item_more_specific = failMaB cur_item
 136       | otherwise                               = -- Less specific, or not unifiable... carry on
 137                                                   insert rest     `thenMaB` \ rest' ->
 138                                                   returnMaB (cur_item : rest')
 139       where
 140         unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
 141         ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
 142         cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
 143 \end{code}
 144
 145 Finally, during simplification we must apply the current substitution to
 146 the SpecEnv.
 147
 148 \begin{code}
 149 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
 150 substSpecEnv ty_env val_fn EmptySE = EmptySE
 151 substSpecEnv ty_env val_fn (SpecEnv alist)
 152   = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
 153   where
 154     ty_fn = applyToTyVars tyvar_fn
 155
 156     -- Apply the substitution; but if we ever substitute
 157     -- we need to convert a Type to a TemplateType
 158     tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
 159                 | otherwise     = case lookupTyVarEnv ty_env tv of
 160                                     Nothing -> mkTyVarTy tv
 161                                     Just ty -> applyToTyVars set_non_tpl ty
 162
 163     set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)
 164 \end{code}