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