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       =
 100 #ifdef DEBUG
 101         if length tpl > length key then
 102                 pprTrace "lookupSpecEnv" (doc <+> ppr tpl <+> ppr key) $
 103                 Nothing
 104         else
 105 #endif
 106         case matchTys tpl key of
 107           Nothing                 -> find rest
 108           Just (subst, leftovers) -> ASSERT( null leftovers )
 109                                      Just (subst, val)
 110 \end{code}
 111
 112 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
 113
 114 A boolean flag controls overlap reporting.
 115
 116 True => overlap is permitted, but only if one template matches the other;
 117         not if they unify but neither is
 118
 119 \begin{code}
 120 addToSpecEnv :: Bool                            -- True <=> overlap permitted
 121              -> SpecEnv value                   -- Envt
 122              -> [TyVar] -> [Type] -> value      -- New item
 123              -> MaybeErr (SpecEnv value)                -- Success...
 124                           ([TemplateType], value)       -- Failure: Offending overlap
 125
 126 addToSpecEnv overlap_ok spec_env tvs tys value
 127   = case spec_env of
 128        EmptySE       -> returnMaB (SpecEnv [ins_item])
 129        SpecEnv alist -> insert alist    `thenMaB` \ alist' ->
 130                         returnMaB (SpecEnv alist')
 131   where
 132     ins_item = (ins_tys, value)
 133     ins_tys  = map (applyToTyVars mk_tv) tys
 134
 135     mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
 136                -- tvs identifies the template variables
 137
 138     insert [] = returnMaB [ins_item]
 139     insert alist@(cur_item@(cur_tys, _) : rest)
 140       | unifiable && not overlap_ok             = failMaB cur_item
 141       | unifiable && ins_item_more_specific     = returnMaB (ins_item : alist)
 142       | unifiable && not cur_item_more_specific = failMaB cur_item
 143       | otherwise                               = -- Less specific, or not unifiable... carry on
 144                                                   insert rest     `thenMaB` \ rest' ->
 145                                                   returnMaB (cur_item : rest')
 146       where
 147         unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
 148         ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
 149         cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
 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 -> (val -> val) -> SpecEnv val -> SpecEnv val
 157 substSpecEnv ty_env val_fn EmptySE = EmptySE
 158 substSpecEnv ty_env val_fn (SpecEnv alist)
 159   = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
 160   where
 161     ty_fn = applyToTyVars tyvar_fn
 162
 163     -- Apply the substitution; but if we ever substitute
 164     -- we need to convert a Type to a TemplateType
 165     tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
 166                 | otherwise     = case lookupTyVarEnv ty_env tv of
 167                                     Nothing -> mkTyVarTy tv
 168                                     Just ty -> applyToTyVars set_non_tpl ty
 169
 170     set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)
 171 \end{code}