ghc/compiler/specialise/SpecTyFuns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SpecTyFuns (
  10         specialiseCallTys,
  11         ConstraintVector(..),
  12         getIdOverloading,
  13         mkConstraintVector,
  14         isUnboxedSpecialisation,
  15
  16         specialiseConstrTys,
  17         mkSpecialisedCon,
  18
  19         argTysMatchSpecTys_error,
  20
  21         pprSpecErrs,
  22
  23         Maybe(..), Pretty(..), UniType
  24     ) where
  25
  26 import AbsUniType
  27 import Bag              ( Bag, isEmptyBag, bagToList )
  28 import FiniteMap        ( FiniteMap, emptyFM, addListToFM_C,
  29                           plusFM_C, keysFM, lookupWithDefaultFM
  30                         )
  31 import Id               ( mkSameSpecCon, getIdUniType,
  32                           isDictFunId, isConstMethodId_maybe,
  33                           isDefaultMethodId_maybe,
  34                           getInstIdModule, Id )
  35 import Maybes
  36 import Outputable
  37 import Pretty
  38 import Util
  39 \end{code}
  40
  41 @specialiseCallTys@ works out which type args don't need to be specialised on,
  42 based on flags, the overloading constraint vector, and the types.
  43
  44 \begin{code}
  45 specialiseCallTys :: Bool               -- Specialise on all type args
  46                   -> Bool               -- Specialise on unboxed type args
  47                   -> Bool               -- Specialise on overloaded type args
  48                   -> ConstraintVector   -- Tells which type args are overloaded
  49                   -> [UniType]          -- Type args
  50                   -> [Maybe UniType]    -- Nothings replace non-specialised type args
  51
  52 specialiseCallTys True _ _ cvec tys
  53   = map Just tys
  54 specialiseCallTys False spec_unboxed spec_overloading cvec tys
  55   = zipWith spec_ty_other cvec tys
  56   where
  57     spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
  58                          || (spec_overloading && c)
  59                          = Just ty
  60                        | otherwise
  61                          = Nothing
  62 \end{code}
  63
  64 @getIdOverloading@ grabs the type of an Id, and returns a
  65 list of its polymorphic variables, and the initial segment of
  66 its ThetaType, in which the classes constrain only type variables.
  67 For example, if the Id's type is
  68
  69         forall a,b,c. Eq a -> Ord [a] -> tau
  70
  71 we'll return
  72
  73         ([a,b,c], [(Eq,a)])
  74
  75 This seems curious at first.  For a start, the type above looks odd,
  76 because we usually only have dictionary args whose types are of
  77 the form (C a) where a is a type variable.  But this doesn't hold for
  78 the functions arising from instance decls, which sometimes get
  79 arguements with types of form (C (T a)) for some type constructor T.
  80
  81 Should we specialise wrt this compound-type dictionary?  This is
  82 a heuristic judgement, as indeed is the fact that we specialise wrt
  83 only dictionaries.  We choose *not* to specialise wrt compound dictionaries
  84 because at the moment the only place they show up is in instance decls,
  85 where they are simply plugged into a returned dictionary.  So nothing is
  86 gained by specialising wrt them.
  87
  88 \begin{code}
  89 getIdOverloading :: Id
  90                  -> ([TyVarTemplate], [(Class,TyVarTemplate)])
  91 getIdOverloading id
  92   = (tyvars, tyvar_part_of theta)
  93   where
  94     (tyvars, theta, _) = splitType (getIdUniType id)
  95
  96     tyvar_part_of []                  = []
  97     tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
  98                                             Nothing    -> []
  99                                             Just tyvar -> (clas, tyvar) : tyvar_part_of theta
 100 \end{code}
 101
 102 \begin{code}
 103 type ConstraintVector = [Bool]  -- True for constrained tyvar, false otherwise
 104
 105 mkConstraintVector :: Id
 106                    -> ConstraintVector
 107
 108 mkConstraintVector id
 109   = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
 110   where
 111     (tyvars, class_tyvar_pairs) = getIdOverloading id
 112     constrained_tyvars   = map snd class_tyvar_pairs    -- May contain dups
 113 \end{code}
 114
 115 \begin{code}
 116 isUnboxedSpecialisation :: [Maybe UniType] -> Bool
 117 isUnboxedSpecialisation tys
 118   = any is_unboxed tys
 119   where
 120     is_unboxed (Just ty) = isUnboxedDataType ty
 121     is_unboxed Nothing   = False
 122 \end{code}
 123
 124 @specialiseConstrTys@ works out which type args don't need to be
 125 specialised on. We only speciailise on unboxed types.
 126
 127 \begin{code}
 128 specialiseConstrTys :: [UniType]
 129                     -> [Maybe UniType]
 130
 131 specialiseConstrTys tys
 132   = map maybe_unboxed_ty tys
 133   where
 134     maybe_unboxed_ty ty = case isUnboxedDataType ty of
 135                             True  -> Just ty
 136                             False -> Nothing
 137 \end{code}
 138
 139 \begin{code}
 140 mkSpecialisedCon :: Id -> [UniType] -> Id
 141 mkSpecialisedCon con tys
 142   = if spec_reqd
 143     then mkSameSpecCon spec_tys con
 144     else con
 145   where
 146     spec_tys  = specialiseConstrTys tys
 147     spec_reqd = maybeToBool (firstJust spec_tys)
 148 \end{code}
 149
 150 @argTysMatchSpecTys@ checks if a list of argument types is consistent
 151 with a list of specialising types. An error message is returned if not.
 152 \begin{code}
 153 argTysMatchSpecTys_error :: [Maybe UniType]
 154                          -> [UniType]
 155                          -> Maybe Pretty
 156 argTysMatchSpecTys_error spec_tys arg_tys
 157   = if match spec_tys arg_tys
 158     then Nothing
 159     else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
 160                       ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
 161                       ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]])
 162   where
 163     match (Nothing:spec_tys) (arg:arg_tys)
 164       = not (isUnboxedDataType arg) &&
 165         match spec_tys arg_tys
 166     match (Just spec:spec_tys) (arg:arg_tys)
 167       = case (cmpUniType True{-properly-} spec arg) of
 168           EQ_   -> match spec_tys arg_tys
 169           other -> False
 170     match [] [] = True
 171     match _  _  = False
 172 \end{code}
 173
 174 @pprSpecErrs@ prints error and warning information
 175 about imported specialisations which do not exist.
 176
 177 \begin{code}
 178 pprSpecErrs :: FAST_STRING                      -- module name
 179             -> (Bag (Id,[Maybe UniType]))       -- errors
 180             -> (Bag (Id,[Maybe UniType]))       -- warnings
 181             -> (Bag (TyCon,[Maybe UniType]))    -- errors
 182             -> Pretty
 183
 184 pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
 185   | not any_errs && not any_warn
 186   = ppNil
 187
 188   | otherwise
 189   = ppAboves [
 190         ppStr "SPECIALISATION MESSAGES:",
 191         ppAboves (map pp_module_specs use_modules)
 192         ]
 193   where
 194     any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
 195     any_warn = not (isEmptyBag spec_warn)
 196
 197     mk_module_fm get_mod_data errs_bag
 198       = addListToFM_C (++) emptyFM errs_list
 199       where
 200         errs_list = map get_mod_data (bagToList errs_bag)
 201
 202     tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
 203
 204     iderrs_fm  = mk_module_fm (get_id_data True) spec_errs
 205     idwarn_fm  = mk_module_fm (get_id_data False) spec_warn
 206     idspecs_fm = plusFM_C (++) idwarn_fm iderrs_fm
 207
 208     get_id_data is_err (id, tys)
 209       = (mod_name, [(id_name, id, tys, is_err)])
 210       where
 211         (mod_name, id_name) = get_id_name id
 212
 213     get_id_name id
 214       | maybeToBool (isDefaultMethodId_maybe id)
 215       = (this_mod, _NIL_)
 216
 217       | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
 218       = let get_mod = getInstIdModule id
 219             use_mod = if from_prelude get_mod
 220                       then SLIT("Prelude")
 221                       else get_mod
 222         in (use_mod, _NIL_)
 223
 224       | otherwise
 225       = getOrigName id
 226
 227     get_ty_data (ty, tys)
 228       = (mod_name, [(ty_name, ty, tys)])
 229       where
 230         (mod_name,ty_name) = getOrigName ty
 231
 232     from_prelude mod
 233       = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
 234
 235     module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
 236     mods            = map head (equivClasses _CMP_STRING_ module_names)
 237
 238     (unks, known)   = if null mods
 239                       then ([], [])
 240                       else case _CMP_STRING_ (head mods) _NIL_ of
 241                             EQ_   -> ([_NIL_], tail mods)
 242                             other -> ([], mods)
 243
 244     (prels, others) = partition from_prelude known
 245     use_modules     = unks ++ prels ++ others
 246
 247     pp_module_specs :: FAST_STRING -> Pretty
 248     pp_module_specs mod
 249       | mod == _NIL_
 250       = ASSERT (null mod_tyspecs)
 251         ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
 252
 253       | have_specs
 254       = ppAboves [
 255             ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
 256             ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
 257             ]
 258
 259       | otherwise
 260       = ppNil
 261
 262       where
 263         mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
 264         mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
 265         have_specs  = not (null mod_tyspecs && null mod_idspecs)
 266         ty_sty = PprInterface (error "SpecTyFuns:PprInterface:sw_chkr")
 267
 268 pp_module mod
 269   = ppBesides [ppPStr mod, ppStr ":"]
 270
 271 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty
 272
 273 pp_tyspec sty pp_mod (_, tycon, tys)
 274   = ppCat [pp_mod,
 275            ppStr "{-# SPECIALIZE", ppStr "data",
 276            pprNonOp PprForUser tycon, ppCat (map (pprParendUniType sty) spec_tys),
 277            ppStr "#-}", ppStr "{- Essential -}"
 278            ]
 279   where
 280     tvs = getTyConTyVarTemplates tycon
 281     (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
 282     spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
 283
 284     choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
 285     choose_ty (tv, Just ty) = (ty, Nothing)
 286
 287 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe UniType], Bool) -> Pretty
 288
 289 pp_idspec sty pp_mod (_, id, tys, is_err)
 290   | isDictFunId id
 291   = ppCat [pp_mod,
 292            ppStr "{-# SPECIALIZE",
 293            ppStr "instance",
 294            pprUniType sty spec_ty,
 295            ppStr "#-}", pp_essential ]
 296
 297   | is_const_method_id
 298   = let
 299         Just (cls, clsty, clsop) = const_method_maybe
 300         (_, cls_str) = getOrigName cls
 301         clsop_str    = getClassOpString clsop
 302     in
 303     ppCat [pp_mod,
 304            ppStr "{-# SPECIALIZE",
 305            pp_clsop clsop_str, ppStr "::",
 306            pprUniType sty spec_ty,
 307            ppStr "#-} {- IN instance",
 308            ppPStr cls_str, pprParendUniType sty clsty,
 309            ppStr "-}", pp_essential ]
 310
 311   | is_default_method_id
 312   = let
 313         Just (cls, clsop, _) = default_method_maybe
 314         (_, cls_str) = getOrigName cls
 315         clsop_str    = getClassOpString clsop
 316     in
 317     ppCat [pp_mod,
 318            ppStr "{- instance",
 319            ppPStr cls_str,
 320            ppStr "EXPLICIT METHOD REQUIRED",
 321            pp_clsop clsop_str, ppStr "::",
 322            pprUniType sty spec_ty,
 323            ppStr "-}", pp_essential ]
 324
 325   | otherwise
 326   = ppCat [pp_mod,
 327            ppStr "{-# SPECIALIZE",
 328            pprNonOp PprForUser id, ppStr "::",
 329            pprUniType sty spec_ty,
 330            ppStr "#-}", pp_essential ]
 331   where
 332     spec_ty = specialiseTy (getIdUniType id) tys 100   -- HACK to drop all dicts!!!
 333     pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
 334
 335     const_method_maybe = isConstMethodId_maybe id
 336     is_const_method_id = maybeToBool const_method_maybe
 337
 338     default_method_maybe = isDefaultMethodId_maybe id
 339     is_default_method_id = maybeToBool default_method_maybe
 340
 341     pp_clsop str | isAvarop str
 342                  = ppBesides [ppLparen, ppPStr str, ppRparen]
 343                  | otherwise
 344                  = ppPStr str
 345
 346 \end{code}