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            ( GenClass{-instance NamedThing-}, GenClassOp {- 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             ( OccName, pprNonSym, pprOccName, modAndOcc )
  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
 232     get_id_name id
 233
 234 {- Don't understand this -- and looks TURGID.  SLPJ 4 Nov 96
 235       | maybeToBool (isDefaultMethodId_maybe id)
 236       = (this_mod, _NIL_)
 237
 238       | isDictFunId id || maybeToBool (isConstMethodId_maybe id)
 239       = let get_mod = getInstIdModule id
 240             use_mod = get_mod
 241         in (use_mod, _NIL_)
 242
 243       | otherwise
 244 -}
 245       = modAndOcc id
 246
 247     get_ty_data (ty, tys)
 248       = (mod_name, [(ty_name, ty, tys)])
 249       where
 250         (mod_name, ty_name) = modAndOcc ty
 251
 252     module_names    = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
 253     mods            = map head (equivClasses _CMP_STRING_ module_names)
 254
 255     (unks, known)   = if null mods
 256                       then ([], [])
 257                       else case _CMP_STRING_ (head mods) _NIL_ of
 258                             EQ_   -> ([_NIL_], tail mods)
 259                             other -> ([], mods)
 260
 261     use_modules     = unks ++ known
 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 -> (OccName, 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 -> (OccName, 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     in
 317     ppCat [pp_mod,
 318            ppStr "{-# SPECIALIZE",
 319            pprNonSym sty clsop, ppStr "::",
 320            pprGenType sty spec_ty,
 321            ppStr "#-} {- IN instance",
 322            pprOccName sty (getOccName cls), pprParendGenType sty clsty,
 323            ppStr "-}", pp_essential ]
 324
 325   | is_default_method_id
 326   = let
 327         Just (cls, clsop, _) = default_method_maybe
 328     in
 329     ppCat [pp_mod,
 330            ppStr "{- instance",
 331            pprOccName sty (getOccName cls),
 332            ppStr "EXPLICIT METHOD REQUIRED",
 333            pprNonSym sty clsop, 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 \end{code}