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