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