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