ghc/compiler/specialise/SpecUtils.lhs

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