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