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 Maybes
  20 import Util             ( assertPanic )
  21 \end{code}
  22
  23
  24
  25 %************************************************************************
  26 %*                                                                      *
  27 \section{SpecEnv}
  28 %*                                                                      *
  29 %************************************************************************
  30
  31 \begin{code}
  32 type TemplateTyVar = GenTyVar Bool
  33 type TemplateType  = GenType Bool
  34       -- The Bool is True for template type variables;
  35       -- that is, ones that can be bound
  36
  37 data SpecEnv value
  38   = EmptySE
  39   | SpecEnv [([TemplateType], value)]
  40
  41 specEnvValues :: SpecEnv value -> [value]
  42 specEnvValues EmptySE         = []
  43 specEnvValues (SpecEnv alist) = map snd alist
  44
  45 specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
  46 specEnvToList EmptySE         = []
  47 specEnvToList (SpecEnv alist)
  48   = map do_item alist
  49   where
  50     do_item (tys, val) = (tyvars, tys, val)
  51                        where
  52                          tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
  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 :: SpecEnv value  -- The envt
  88               -> [GenType flexi]                -- Key
  89               -> Maybe (TyVarEnv (GenType flexi), value)
  90
  91 lookupSpecEnv EmptySE key = Nothing
  92 lookupSpecEnv (SpecEnv alist) key
  93   = find alist
  94   where
  95     find [] = Nothing
  96     find ((tpl, val) : rest)
  97       = case matchTys tpl key of
  98           Nothing                 -> find rest
  99           Just (subst, leftovers) -> ASSERT( null leftovers )
 100                                      Just (subst, val)
 101 \end{code}
 102
 103 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
 104
 105 A boolean flag controls overlap reporting.
 106
 107 True => overlap is permitted, but only if one template matches the other;
 108         not if they unify but neither is
 109
 110 \begin{code}
 111 addToSpecEnv :: Bool                            -- True <=> overlap permitted
 112              -> SpecEnv value                   -- Envt
 113              -> [TyVar] -> [Type] -> value      -- New item
 114              -> MaybeErr (SpecEnv value)                -- Success...
 115                           ([TemplateType], value)       -- Failure: Offending overlap
 116
 117 addToSpecEnv overlap_ok spec_env tvs tys value
 118   = case spec_env of
 119        EmptySE       -> returnMaB (SpecEnv [ins_item])
 120        SpecEnv alist -> insert alist    `thenMaB` \ alist' ->
 121                         returnMaB (SpecEnv alist')
 122   where
 123     ins_item = (ins_tys, value)
 124     ins_tys  = map (applyToTyVars mk_tv) tys
 125
 126     mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
 127                -- tvs identifies the template variables
 128
 129     insert [] = returnMaB [ins_item]
 130     insert alist@(cur_item@(cur_tys, _) : rest)
 131       | unifiable && not overlap_ok             = failMaB cur_item
 132       | unifiable && ins_item_more_specific     = returnMaB (ins_item : alist)
 133       | unifiable && not cur_item_more_specific = failMaB cur_item
 134       | otherwise                               = -- Less specific, or not unifiable... carry on
 135                                                   insert rest     `thenMaB` \ rest' ->
 136                                                   returnMaB (cur_item : rest')
 137       where
 138         unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
 139         ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
 140         cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
 141 \end{code}
 142
 143 Finally, during simplification we must apply the current substitution to
 144 the SpecEnv.
 145
 146 \begin{code}
 147 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
 148 substSpecEnv ty_env val_fn EmptySE = EmptySE
 149 substSpecEnv ty_env val_fn (SpecEnv alist)
 150   = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
 151   where
 152     ty_fn = applyToTyVars tyvar_fn
 153
 154     -- Apply the substitution; but if we ever substitute
 155     -- we need to convert a Type to a TemplateType
 156     tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
 157                 | otherwise     = case lookupTyVarEnv ty_env tv of
 158                                     Nothing -> mkTyVarTy tv
 159                                     Just ty -> applyToTyVars set_non_tpl ty
 160
 161     set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)
 162 \end{code}