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 #include "HsVersions.h"
   8
   9 module SpecEnv (
  10         SpecEnv(..), MatchEnv,
  11         nullSpecEnv, isNullSpecEnv,
  12         addOneToSpecEnv, lookupSpecEnv,
  13         specEnvToList
  14     ) where
  15
  16 IMP_Ubiq()
  17
  18 import MatchEnv
  19 import Type             ( matchTys, isTyVarTy )
  20 import Usage            ( UVar(..) )
  21 \end{code}
  22
  23
  24 A @SpecEnv@ holds details of an @Id@'s specialisations:
  25
  26 \begin{code}
  27 type CoreExpr = GenCoreExpr Id Id TyVar Unique
  28 type SpecEnv = MatchEnv [Type] CoreExpr
  29 \end{code}
  30
  31 For example, if \tr{f}'s @SpecEnv@ contains the mapping:
  32 \begin{verbatim}
  33         [List a, b]  ===>  (\d -> f' a b)
  34 \end{verbatim}
  35 then
  36 \begin{verbatim}
  37         f (List Int) Bool d  ===>  f' Int Bool
  38 \end{verbatim}
  39
  40 \begin{code}
  41 nullSpecEnv :: SpecEnv
  42 nullSpecEnv = nullMEnv
  43
  44 isNullSpecEnv :: SpecEnv -> Bool
  45 isNullSpecEnv env = null (mEnvToList env)
  46
  47 specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
  48 specEnvToList env = mEnvToList env
  49
  50 addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
  51 addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
  52
  53 lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
  54 lookupSpecEnv env tys
  55   | all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
  56   | otherwise         = lookupMEnv matchTys env tys
  57 \end{code}
  58
  59
  60
  61 =================================================================
  62         BELOW HERE SCHEDULED FOR DELETION!
  63
  64
  65 The details of one specialisation, held in an @Id@'s
  66 @SpecEnv@ are as follows:
  67 \begin{pseudocode}
  68 data SpecInfo
  69   = SpecInfo    [Maybe Type] -- Instance types; no free type variables in here
  70                 Int             -- No. of dictionaries to eat
  71                 Id              -- Specialised version
  72 \end{pseudocode}
  73
  74 For example, if \tr{f} has this @SpecInfo@:
  75 \begin{verbatim}
  76         SpecInfo [Just t1, Nothing, Just t3] 2 f'
  77 \end{verbatim}
  78 then
  79 \begin{verbatim}
  80         f t1 t2 t3 d1 d2  ===>  f t2
  81 \end{verbatim}
  82 The \tr{Nothings} identify type arguments in which the specialised
  83 version is polymorphic.
  84
  85 \begin{pseudocode}
  86 data SpecEnv = SpecEnv [SpecInfo]
  87
  88 mkSpecEnv = SpecEnv
  89 nullSpecEnv = SpecEnv []
  90 addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
  91
  92
  93 lookupConstMethodId :: Id -> Type -> Maybe Id
  94     -- slight variant on "lookupSpecEnv" below
  95
  96 lookupConstMethodId sel_id spec_ty
  97   = case (getInfo (getIdInfo sel_id)) of
  98       SpecEnv spec_infos -> firstJust (map try spec_infos)
  99   where
 100     try (SpecInfo (Just ty:nothings) _ const_meth_id)
 101       = ASSERT(all nothing_is_nothing nothings)
 102         case (cmpType True{-properly-} ty spec_ty) of
 103           EQ_ -> Just const_meth_id
 104           _   -> Nothing
 105
 106     nothing_is_nothing Nothing = True  -- debugging only
 107     nothing_is_nothing _ = panic "nothing_is_nothing!"
 108
 109 lookupSpecId :: Id              -- *un*specialised Id
 110              -> [Maybe Type]    -- types to which it is to be specialised
 111              -> Id              -- specialised Id
 112
 113 lookupSpecId unspec_id ty_maybes
 114   = case (getInfo (getIdInfo unspec_id))  of { SpecEnv spec_infos ->
 115
 116     case (firstJust (map try spec_infos)) of
 117       Just id -> id
 118       Nothing -> pprError "ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"
 119                           (ppr PprDebug unspec_id)
 120     }
 121   where
 122     try (SpecInfo template_maybes _ id)
 123         | and (zipWith same template_maybes ty_maybes)
 124         && length template_maybes == length ty_maybes = Just id
 125         | otherwise                                   = Nothing
 126
 127     same Nothing    Nothing    = True
 128     same (Just ty1) (Just ty2) = ty1 == ty2
 129     same _          _          = False
 130
 131 lookupSpecEnv :: SpecEnv
 132               -> [Type]
 133               -> Maybe (Id,
 134                         [Type],
 135                         Int)
 136
 137 lookupSpecEnv (SpecEnv []) _ = Nothing  -- rather common case
 138
 139 lookupSpecEnv spec_env [] = Nothing     -- another common case
 140
 141         -- This can happen even if there is a non-empty spec_env, because
 142         -- of eta reduction.  For example, we might have a defn
 143         --
 144         --      f = /\a -> \d -> g a d
 145         -- which gets transformed to
 146         --      f = g
 147         --
 148         -- Now g isn't applied to any arguments
 149
 150 lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
 151   = select_match spec_infos
 152   where
 153     select_match []             -- no matching spec_infos
 154       = Nothing
 155     select_match (SpecInfo ty_maybes toss spec_id : rest)
 156       = case (match ty_maybes spec_tys) of
 157           Nothing       -> select_match rest
 158           Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
 159
 160         -- Ambiguity can only arise as a result of specialisations with
 161         -- an explicit spec_id. The best match is deemed to be the match
 162         -- with least polymorphism i.e. has the least number of tys left.
 163         -- This is a non-critical approximation. The only type arguments
 164         -- where there may be some discretion is for non-overloaded boxed
 165         -- types. Unboxed types must be matched and we insist that we
 166         -- always specialise on overloaded types (and discard all the dicts).
 167
 168     select_next best _ toss []
 169       = case best of
 170             [match] -> Just match       -- Unique best match
 171             ambig   -> pprPanic "Ambiguous Specialisation:\n"
 172                                 (ppAboves [ppStr "(check specialisations with explicit spec ids)",
 173                                            ppCat (ppStr "between spec ids:" :
 174                                                   map (ppr PprDebug) [id | (id, _, _) <- ambig]),
 175                                            pp_stuff])
 176
 177     select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
 178       = ASSERT(dnum == toss)
 179         case (match ty_maybes spec_tys) of
 180           Nothing       -> select_next best tnum dnum rest
 181           Just tys_left ->
 182              let tys_len = length tys_left in
 183              case _tagCmp tnum tys_len of
 184                _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest   -- better match
 185                _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match
 186                _GT -> select_next best tnum dnum rest                           -- worse match
 187
 188
 189     match [{-out of templates-}] [] = Just []
 190
 191     match (Nothing:ty_maybes) (spec_ty:spec_tys)
 192       = case (isUnboxedType spec_ty) of
 193           True  -> Nothing      -- Can only match boxed type against
 194                                 -- type argument which has not been
 195                                 -- specialised on
 196           False -> case match ty_maybes spec_tys of
 197                      Nothing  -> Nothing
 198                      Just tys -> Just (spec_ty:tys)
 199
 200     match (Just ty:ty_maybes) (spec_ty:spec_tys)
 201       = case (cmpType True{-properly-} ty spec_ty) of
 202           EQ_   -> match ty_maybes spec_tys
 203           other -> Nothing
 204
 205     match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
 206                  -- This is a Real Problem
 207
 208     match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
 209                  -- Partial eta abstraction might make this happen;
 210                  -- meanwhile let's leave in the check
 211
 212     pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
 213 \end{pseudocode}
 214
 215
 216 \begin{pseudocode}
 217 instance OptIdInfo SpecEnv where
 218     noInfo = nullSpecEnv
 219
 220     getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
 221
 222     addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
 223         = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
 224         -- We *add* the new specialisation info rather than just replacing it
 225         -- so that we don't lose old specialisation details.
 226
 227     ppInfo sty better_id_fn spec_env
 228       = pp_specs sty True better_id_fn nullIdEnv spec_env
 229
 230 pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
 231 pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
 232   = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
 233        ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
 234               ppInt numds,
 235               let
 236                  better_spec_id = better_id_fn spec_id
 237                  spec_id_info = getIdInfo better_spec_id
 238               in
 239               if not print_spec_ids || boringIdInfo spec_id_info then
 240                  ppNil
 241               else
 242                  ppCat [ppChar '{',
 243                         ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
 244                         ppChar '}']
 245              ]
 246        | (SpecInfo ty_maybes numds spec_id) <- specs ])
 247   where
 248     pp_the_list [p]    = p
 249     pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
 250
 251     pp_maybe Nothing  = ifPprInterface sty pp_NONE
 252     pp_maybe (Just t) = pprParendGenType sty t
 253 \end{pseudocode}
 254