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