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