ghc/compiler/specialise/SpecTyFuns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SpecTyFuns (
  10         specialiseCallTys,
  11         ConstraintVector(..),
  12         mkConstraintVector,
  13         isUnboxedSpecialisation,
  14
  15         specialiseConstrTys,
  16         mkSpecialisedCon,
  17
  18         argTysMatchSpecTys_error,
  19
  20         pprSpecErrs,
  21
  22         Maybe(..), Pretty(..), UniType
  23     ) where
  24
  25 import AbsUniType
  26 import Bag              ( Bag, isEmptyBag, bagToList )
  27 import FiniteMap        ( FiniteMap, emptyFM, addListToFM_C,
  28                           keysFM, lookupWithDefaultFM
  29                         )
  30 import Id               ( mkSameSpecCon, getIdUniType,
  31                           isDictFunId, isConstMethodId, Id )
  32 import Maybes
  33 import Outputable
  34 import Pretty
  35 import Util
  36 \end{code}
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[@specialiseTys@]{Determine specialising types}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 @specialiseCallTys@ works out which type args don't need to be specialised on,
  45 based on flags, the overloading constraint vector, and the types.
  46
  47 \begin{code}
  48 specialiseCallTys :: Bool               -- Specialise on all type args
  49                   -> Bool               -- Specialise on unboxed type args
  50                   -> Bool               -- Specialise on overloaded type args
  51                   -> ConstraintVector   -- Tells which type args are overloaded
  52                   -> [UniType]          -- Type args
  53                   -> [Maybe UniType]    -- Nothings replace non-specialised type args
  54
  55 specialiseCallTys True _ _ cvec tys
  56   = map Just tys
  57 specialiseCallTys False spec_unboxed spec_overloading cvec tys
  58   = zipWith spec_ty_other cvec tys
  59   where
  60     spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
  61                          || (spec_overloading && c)
  62                          = Just ty
  63                        | otherwise
  64                          = Nothing
  65
  66 type ConstraintVector = [Bool]  -- True for constrained tyvar, false otherwise
  67
  68 mkConstraintVector :: [TyVarTemplate]
  69                    -> [(Class,TyVarTemplate)]
  70                    -> ConstraintVector
  71
  72 mkConstraintVector tyvars class_tyvar_pairs
  73   = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
  74   where
  75     constrained_tyvars   = map snd class_tyvar_pairs    -- May contain dups
  76 \end{code}
  77
  78 \begin{code}
  79 isUnboxedSpecialisation :: [Maybe UniType] -> Bool
  80 isUnboxedSpecialisation tys
  81   = any is_unboxed tys
  82   where
  83     is_unboxed (Just ty) = isUnboxedDataType ty
  84     is_unboxed Nothing   = False
  85 \end{code}
  86
  87 @specialiseConstrTys@ works out which type args don't need to be
  88 specialised on. We only speciailise on unboxed types.
  89
  90 \begin{code}
  91 specialiseConstrTys :: [UniType]
  92                     -> [Maybe UniType]
  93
  94 specialiseConstrTys tys
  95   = map maybe_unboxed_ty tys
  96   where
  97     maybe_unboxed_ty ty = case isUnboxedDataType ty of
  98                             True  -> Just ty
  99                             False -> Nothing
 100 \end{code}
 101
 102 \begin{code}
 103 mkSpecialisedCon :: Id -> [UniType] -> Id
 104 mkSpecialisedCon con tys
 105   = if spec_reqd
 106     then mkSameSpecCon spec_tys con
 107     else con
 108   where
 109     spec_tys  = specialiseConstrTys tys
 110     spec_reqd = maybeToBool (firstJust spec_tys)
 111 \end{code}
 112
 113 @argTysMatchSpecTys@ checks if a list of argument types is consistent
 114 with a list of specialising types. An error message is returned if not.
 115 \begin{code}
 116 argTysMatchSpecTys_error :: [Maybe UniType]
 117                          -> [UniType]
 118                          -> Maybe Pretty
 119 argTysMatchSpecTys_error spec_tys arg_tys
 120   = if match spec_tys arg_tys
 121     then Nothing
 122     else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
 123                       ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
 124                       ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]])
 125   where
 126     match (Nothing:spec_tys) (arg:arg_tys)
 127       = not (isUnboxedDataType arg) &&
 128         match spec_tys arg_tys
 129     match (Just spec:spec_tys) (arg:arg_tys)
 130       = case (cmpUniType True{-properly-} spec arg) of
 131           EQ_   -> match spec_tys arg_tys
 132           other -> False
 133     match [] [] = True
 134     match _  _  = False
 135 \end{code}
 136
 137 @pprSpecErrs@ prints error and warning information
 138 about imported specialisations which do not exist.
 139
 140 \begin{code}
 141 pprSpecErrs :: PprStyle
 142             -> (Bag (Id,[Maybe UniType]))       -- errors
 143             -> (Bag (Id,[Maybe UniType]))       -- warnings
 144             -> (Bag (TyCon,[Maybe UniType]))    -- errors
 145             -> Pretty
 146
 147 pprSpecErrs sty spec_errs spec_warn spec_tyerrs
 148   | not any_errs && not any_warn
 149   = ppNil
 150
 151   | otherwise
 152   = ppAboves [if any_errs then ppAboves [
 153                   ppStr "SPECIALISATION ERRORS (Essential):",
 154                   ppAboves (map pp_module_errs use_modules),
 155                   ppStr "***"
 156                   ]
 157               else
 158                   ppNil,
 159               if any_warn then ppAboves [
 160                   ppStr "SPECIALISATION MESSAGES (Desirable):",
 161                   ppAboves (map pp_module_warn use_modules),
 162                   ppStr "***"
 163                   ]
 164               else
 165                   ppNil
 166              ]
 167   where
 168     any_errs = not (isEmptyBag spec_errs) || not (isEmptyBag spec_tyerrs)
 169     any_warn = not (isEmptyBag spec_warn)
 170
 171     mk_module_fm errs_bag
 172       = addListToFM_C (++) emptyFM errs_list
 173       where
 174         errs_list = map add_name (bagToList errs_bag)
 175
 176     add_name (id, tys) = (mod, [(name, id, tys)])
 177                        where
 178                          (mod,name) = getOrigName id
 179
 180     tyerrs_fm = mk_module_fm spec_tyerrs
 181     errs_fm   = mk_module_fm spec_errs
 182     warn_fm   = mk_module_fm spec_warn
 183
 184     module_names   = concat [keysFM errs_fm, keysFM warn_fm, keysFM tyerrs_fm]
 185     sorted_modules = map head (equivClasses _CMP_STRING_ module_names)
 186
 187         -- Ensure any dfun instance specialisations (module _NIL_) are printed last
 188         -- ToDo: Print instance specialisations with the instance module
 189         --       This requires the module which defined the instance to be known:
 190         --       add_name could then extract the instance module for a dfun id
 191         --       and pp_dfun made a special case of pp_err
 192     use_modules = if (head sorted_modules == _NIL_)
 193                   then tail sorted_modules ++ [_NIL_]
 194                   else sorted_modules
 195
 196
 197     pp_module_errs :: FAST_STRING -> Pretty
 198     pp_module_errs mod
 199       | have_errs && mod == _NIL_
 200         -- A _NIL_ module string corresponds to internal Ids
 201         -- The only ones for which call instances should arise are
 202         --   dfuns which correspond to instance specialisations
 203       = ASSERT (null mod_tyerrs)
 204         ppAboves [
 205             ppStr "*** INSTANCES",
 206             ppAboves (map (pp_dfun sty) mod_errs)
 207             ]
 208
 209       | have_errs
 210       = ppAboves [
 211             pp_module mod,
 212             ppAboves (map (pp_err sty) mod_errs),
 213             ppAboves (map (pp_tyerr sty) mod_tyerrs)
 214             ]
 215
 216       | otherwise
 217       = ppNil
 218
 219       where
 220         mod_tyerrs = lookupWithDefaultFM tyerrs_fm [] mod
 221         mod_errs   = lookupWithDefaultFM errs_fm [] mod
 222         have_errs  = not (null mod_tyerrs) || not (null mod_errs)
 223
 224
 225     pp_module_warn :: FAST_STRING -> Pretty
 226     pp_module_warn mod
 227       | have_warn && mod == _NIL_
 228         -- A _NIL_ module string corresponds to internal Ids
 229         -- The only ones for which call instances should arise are
 230         --   dfuns which correspond to instance specialisations
 231       = ppAboves [
 232             ppStr "*** INSTANCES",
 233             ppAboves (map (pp_dfun sty) mod_warn)
 234             ]
 235
 236       | have_warn
 237       = ppAboves [
 238             pp_module mod,
 239             ppAboves (map (pp_err sty) mod_warn)
 240             ]
 241
 242       | otherwise
 243       = ppNil
 244
 245       where
 246         mod_warn  = lookupWithDefaultFM warn_fm [] mod
 247         have_warn = not (null mod_warn)
 248
 249
 250 pp_module mod
 251   = ppCat [ppStr "*** module", ppPStr mod, ppStr "***"]
 252
 253
 254 pp_tyerr :: PprStyle -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty
 255
 256 pp_tyerr sty (_, tycon, tys)
 257   = ppCat [ppStr "{-# SPECIALIZE data",
 258            pprNonOp sty tycon, ppCat (map (pprParendUniType sty) spec_tys),
 259            ppStr "#-}" ]
 260   where
 261     tvs = getTyConTyVarTemplates tycon
 262     (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
 263     spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
 264
 265     choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
 266     choose_ty (tv, Just ty) = (ty, Nothing)
 267
 268 pp_err sty (_, id, tys)
 269   = ppCat [ppStr "{-# SPECIALIZE",
 270            pprNonOp sty id, ppStr "::",
 271            pprUniType sty spec_ty,
 272            ppStr "#-}" ]
 273   where
 274     spec_ty = specialiseTy (getIdUniType id) tys 100   -- HACK to drop all dicts!!!
 275
 276 pp_dfun sty (_, id, tys)
 277   | isDictFunId id
 278   = ppCat [ppStr "{-# SPECIALIZE instance",
 279            pprUniType sty spec_ty,
 280            ppStr "#-}" ]
 281   | isConstMethodId id
 282   = pp_comment sty "OVERLOADED METHOD" id spec_ty
 283   | otherwise
 284   = pp_comment sty "HELP ..." id spec_ty
 285   where
 286     spec_ty = specialiseTy (getIdUniType id) tys 100   -- HACK to drop all dicts!!!
 287
 288 pp_comment sty msg id spec_ty
 289   = ppCat [ppStr "{-", ppStr msg,
 290            pprNonOp sty id, ppStr "::",
 291            pprUniType sty spec_ty,
 292            ppStr "-}" ]
 293 \end{code}