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         addToSpecEnv, matchSpecEnv, unifySpecEnv
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import Type             ( Type, GenType, matchTys, tyVarsOfTypes )
  16 import TyVar            ( TyVar, TyVarEnv, 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 data SpecEnv value
  32   = EmptySE
  33   | SpecEnv [([Type], value)]   -- No pair of templates unify with each others
  34 \end{code}
  35
  36 For now we just use association lists.
  37
  38 \begin{code}
  39 emptySpecEnv :: SpecEnv a
  40 emptySpecEnv = EmptySE
  41
  42 isEmptySpecEnv EmptySE = True
  43 isEmptySpecEnv _       = False
  44 \end{code}
  45
  46 @lookupSpecEnv@ looks up in a @SpecEnv@.  Since no pair of templates
  47 unify, the first match must be the only one.
  48
  49 \begin{code}
  50 data SpecEnvResult val
  51   = Match Subst val     -- Match, instantiating only
  52                         -- type variables in the template
  53
  54   | CouldMatch          -- A match could happen if the
  55                         -- some of the type variables in the key
  56                         -- were further instantiated.
  57
  58   | NoMatch             -- No match possible, regardless of how
  59                         -- the key is further instantiated
  60
  61 -- If the key *unifies* with one of the templates, then the
  62 -- result is Match or CouldMatch, depending on whether any of the
  63 -- type variables in the key had to be instantiated
  64
  65 unifySpecEnv :: SpecEnv value   -- The envt
  66               -> [Type]         -- Key
  67               -> SpecEnvResult value
  68
  69
  70 unifySpecEnv EmptySE key = NoMatch
  71 unifySpecEnv (SpecEnv alist) key
  72   = find alist
  73   where
  74     find [] = NoMatch
  75     find ((tpl, val) : rest)
  76       = case unifyTyListsX tpl key of
  77           Nothing    -> find rest
  78           Just subst |  all uninstantiated (tyVarSetToList (tyVarsOfTypes key))
  79                      -> Match subst val
  80                      |  otherwise
  81                      -> CouldMatch
  82                      where
  83                        uninstantiated tv = case lookupTyVarEnv subst tv of
  84                                              Just xx -> False
  85                                              Nothing -> True
  86
  87 -- matchSpecEnv does a one-way match only, but in return
  88 -- it is more polymorphic than unifySpecEnv
  89
  90 matchSpecEnv :: SpecEnv value   -- The envt
  91              -> [GenType flexi]         -- Key
  92              -> Maybe (TyVarEnv (GenType flexi), value)
  93
  94 matchSpecEnv EmptySE key = Nothing
  95 matchSpecEnv (SpecEnv alist) key
  96   = find alist
  97   where
  98     find [] = Nothing
  99     find ((tpl, val) : rest)
 100       = case matchTys tpl key of
 101           Nothing    -> find rest
 102           Just (subst, leftovers) -> ASSERT( null leftovers )
 103                                      Just (subst, val)
 104 \end{code}
 105
 106 @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
 107
 108 \begin{code}
 109 addToSpecEnv :: SpecEnv value                   -- Envt
 110               -> [Type] -> value                -- New item
 111               -> MaybeErr (SpecEnv value)       -- Success...
 112                           ([Type], value)       -- Failure: Offending overlap
 113
 114 addToSpecEnv EmptySE         key value = returnMaB (SpecEnv [(key, value)])
 115 addToSpecEnv (SpecEnv alist) key value
 116   = case filter matches_key alist of
 117       []        -> returnMaB (SpecEnv ((key,value) : alist))    -- No match
 118       (bad : _) -> failMaB bad                                  -- At least one match
 119   where
 120     matches_key (tpl, val) = maybeToBool (unifyTyListsX tpl key)
 121 \end{code}