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