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, specEnvValues,
  10         addToSpecEnv, lookupSpecEnv, substSpecEnv
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Type             ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
  16 import TyVar            ( TyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
  17 import Unify            ( Subst, unifyTyListsX )
  18 import Maybes
  19 import Util             ( assertPanic )
  20 \end{code}
  21
  22
  23
  24 %************************************************************************
  25 %*                                                                      *
  26 \section{SpecEnv}
  27 %*                                                                      *
  28 %************************************************************************
  29
  30 \begin{code}
  31 type TemplateType = GenType Bool
  32       -- The Bool is True for template type variables;
  33       -- that is, ones that can be bound
  34
  35 data SpecEnv value
  36   = EmptySE
  37   | SpecEnv [([TemplateType], value)]
  38
  39 specEnvValues :: SpecEnv value -> [value]
  40 specEnvValues EmptySE         = []
  41 specEnvValues (SpecEnv alist) = map snd alist
  42 \end{code}
  43
  44 In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
  45
  46 In others, overlap is permitted, but only in such a way that one can make
  47 a unique choice when looking up.  That is, overlap is only permitted if
  48 one template matches the other, or vice versa.  So this is ok:
  49
  50   [a]  [Int]
  51
  52 but this is not
  53
  54   (Int,a)  (b,Int)
  55
  56 If overlap is permitted, the list is kept most specific first, so that
  57 the first lookup is the right choice.
  58
  59
  60 For now we just use association lists.
  61
  62 \begin{code}
  63 emptySpecEnv :: SpecEnv a
  64 emptySpecEnv = EmptySE
  65
  66 isEmptySpecEnv EmptySE = True
  67 isEmptySpecEnv _       = False
  68 \end{code}
  69
  70 @lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match.  Since the env is kept
  71 ordered, the first match must be the only one.
  72 The thing we are looking up can have an
  73 arbitrary "flexi" part.
  74
  75 \begin{code}
  76 lookupSpecEnv :: SpecEnv value  -- The envt
  77               -> [GenType flexi]                -- Key
  78               -> Maybe (TyVarEnv (GenType flexi), value)
  79
  80 lookupSpecEnv EmptySE key = Nothing
  81 lookupSpecEnv (SpecEnv alist) key
  82   = find alist
  83   where
  84     find [] = Nothing
  85     find ((tpl, val) : rest)
  86       = case matchTys tpl key of
  87           Nothing                 -> find rest
  88           Just (subst, leftovers) -> ASSERT( null leftovers )
  89                                      Just (subst, val)
  90 \end{code}
  91
  92 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
  93
  94 A boolean flag controls overlap reporting.
  95
  96 True => overlap is permitted, but only if one template matches the other;
  97         not if they unify but neither is
  98
  99 \begin{code}
 100 addToSpecEnv :: Bool                            -- True <=> overlap permitted
 101              -> SpecEnv value                   -- Envt
 102              -> [TyVar] -> [Type] -> value      -- New item
 103              -> MaybeErr (SpecEnv value)                -- Success...
 104                           ([TemplateType], value)       -- Failure: Offending overlap
 105
 106 addToSpecEnv overlap_ok spec_env tvs tys value
 107   = case spec_env of
 108        EmptySE       -> returnMaB (SpecEnv [ins_item])
 109        SpecEnv alist -> insert alist    `thenMaB` \ alist' ->
 110                         returnMaB (SpecEnv alist')
 111   where
 112     ins_item = (ins_tys, value)
 113     ins_tys  = map (applyToTyVars mk_tv) tys
 114
 115     mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs))
 116                -- tvs identifies the template variables
 117
 118     insert [] = returnMaB [ins_item]
 119     insert alist@(cur_item@(cur_tys, _) : rest)
 120       | unifiable && not overlap_ok             = failMaB cur_item
 121       | unifiable && ins_item_more_specific     = returnMaB (ins_item : alist)
 122       | unifiable && not cur_item_more_specific = failMaB cur_item
 123       | otherwise                               = -- Less specific, or not unifiable... carry on
 124                                                   insert rest     `thenMaB` \ rest' ->
 125                                                   returnMaB (cur_item : rest')
 126       where
 127         unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys)
 128         ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys)
 129         cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys)
 130 \end{code}
 131
 132 Finally, during simplification we must apply the current substitution to
 133 the SpecEnv.
 134
 135 \begin{code}
 136 substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val
 137 substSpecEnv ty_env val_fn EmptySE = EmptySE
 138 substSpecEnv ty_env val_fn (SpecEnv alist)
 139   = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist]
 140   where
 141     ty_fn = applyToTyVars tyvar_fn
 142
 143     -- Apply the substitution; but if we ever substitute
 144     -- we need to convert a Type to a TemplateType
 145     tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv
 146                 | otherwise     = case lookupTyVarEnv ty_env tv of
 147                                     Nothing -> mkTyVarTy tv
 148                                     Just ty -> applyToTyVars set_non_tpl ty
 149
 150     set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False)
 151 \end{code}