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 import Ubiq{-uitous-}
  25
  26 import Bag              ( isEmptyBag, bagToList )
  27 import Class            ( getClassOpString, 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 Outputable       ( isAvarop, pprNonOp )
  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 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 = if from_prelude get_mod
 238                       then SLIT("Prelude")
 239                       else get_mod
 240         in (use_mod, _NIL_)
 241
 242       | otherwise
 243       = getOrigName id
 244
 245     get_ty_data (ty, tys)
 246       = (mod_name, [(ty_name, ty, tys)])
 247       where
 248         (mod_name,ty_name) = getOrigName ty
 249
 250     from_prelude mod
 251       = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
 252
 253     module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
 254     mods            = map head (equivClasses _CMP_STRING_ module_names)
 255
 256     (unks, known)   = if null mods
 257                       then ([], [])
 258                       else case _CMP_STRING_ (head mods) _NIL_ of
 259                             EQ_   -> ([_NIL_], tail mods)
 260                             other -> ([], mods)
 261
 262     (prels, others) = partition from_prelude known
 263     use_modules     = unks ++ prels ++ others
 264
 265     pp_module_specs :: FAST_STRING -> Pretty
 266     pp_module_specs mod
 267       | mod == _NIL_
 268       = ASSERT (null mod_tyspecs)
 269         ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
 270
 271       | have_specs
 272       = ppAboves [
 273             ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
 274             ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
 275             ]
 276
 277       | otherwise
 278       = ppNil
 279
 280       where
 281         mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
 282         mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
 283         have_specs  = not (null mod_tyspecs && null mod_idspecs)
 284         ty_sty = PprInterface
 285
 286 pp_module mod
 287   = ppBesides [ppPStr mod, ppStr ":"]
 288
 289 pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
 290
 291 pp_tyspec sty pp_mod (_, tycon, tys)
 292   = ppCat [pp_mod,
 293            ppStr "{-# SPECIALIZE", ppStr "data",
 294            pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys),
 295            ppStr "#-}", ppStr "{- Essential -}"
 296            ]
 297   where
 298     tvs = tyConTyVars tycon
 299     (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
 300     spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
 301
 302     choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
 303     choose_ty (tv, Just ty) = (ty, Nothing)
 304
 305 pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
 306
 307 pp_idspec sty pp_mod (_, id, tys, is_err)
 308   | isDictFunId id
 309   = ppCat [pp_mod,
 310            ppStr "{-# SPECIALIZE",
 311            ppStr "instance",
 312            pprGenType sty spec_ty,
 313            ppStr "#-}", pp_essential ]
 314
 315   | is_const_method_id
 316   = let
 317         Just (cls, clsty, clsop) = const_method_maybe
 318         (_, cls_str) = getOrigName cls
 319         clsop_str    = getClassOpString clsop
 320     in
 321     ppCat [pp_mod,
 322            ppStr "{-# SPECIALIZE",
 323            pp_clsop clsop_str, ppStr "::",
 324            pprGenType sty spec_ty,
 325            ppStr "#-} {- IN instance",
 326            ppPStr cls_str, pprParendGenType sty clsty,
 327            ppStr "-}", pp_essential ]
 328
 329   | is_default_method_id
 330   = let
 331         Just (cls, clsop, _) = default_method_maybe
 332         (_, cls_str) = getOrigName cls
 333         clsop_str    = getClassOpString clsop
 334     in
 335     ppCat [pp_mod,
 336            ppStr "{- instance",
 337            ppPStr cls_str,
 338            ppStr "EXPLICIT METHOD REQUIRED",
 339            pp_clsop clsop_str, ppStr "::",
 340            pprGenType sty spec_ty,
 341            ppStr "-}", pp_essential ]
 342
 343   | otherwise
 344   = ppCat [pp_mod,
 345            ppStr "{-# SPECIALIZE",
 346            pprNonOp PprForUser id, ppStr "::",
 347            pprGenType sty spec_ty,
 348            ppStr "#-}", pp_essential ]
 349   where
 350     spec_ty = specialiseTy (idType id) tys 100   -- HACK to drop all dicts!!!
 351     pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
 352
 353     const_method_maybe = isConstMethodId_maybe id
 354     is_const_method_id = maybeToBool const_method_maybe
 355
 356     default_method_maybe = isDefaultMethodId_maybe id
 357     is_default_method_id = maybeToBool default_method_maybe
 358
 359     pp_clsop str | isAvarop str
 360                  = ppBesides [ppLparen, ppPStr str, ppRparen]
 361                  | otherwise
 362                  = ppPStr str
 363
 364 \end{code}