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