\begin{code}
#include "HsVersions.h"
-module SpecTyFuns (
+module SpecUtils (
specialiseCallTys,
ConstraintVector(..),
getIdOverloading,
argTysMatchSpecTys_error,
- pprSpecErrs,
-
- Maybe(..), Pretty(..), UniType
+ pprSpecErrs
) where
-import AbsUniType
+import Type
import Bag ( Bag, isEmptyBag, bagToList )
import FiniteMap ( FiniteMap, emptyFM, addListToFM_C,
plusFM_C, keysFM, lookupWithDefaultFM
)
-import Id ( mkSameSpecCon, getIdUniType,
+import Id ( mkSameSpecCon, idType,
isDictFunId, isConstMethodId_maybe,
isDefaultMethodId_maybe,
getInstIdModule, Id )
-import Maybes
+import Maybes
import Outputable
import Pretty
import Util
-> Bool -- Specialise on unboxed type args
-> Bool -- Specialise on overloaded type args
-> ConstraintVector -- Tells which type args are overloaded
- -> [UniType] -- Type args
- -> [Maybe UniType] -- Nothings replace non-specialised type args
+ -> [Type] -- Type args
+ -> [Maybe Type] -- Nothings replace non-specialised type args
specialiseCallTys True _ _ cvec tys
= map Just tys
specialiseCallTys False spec_unboxed spec_overloading cvec tys
- = zipWith spec_ty_other cvec tys
+ = zipWithEqual spec_ty_other cvec tys
where
spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
- || (spec_overloading && c)
- = Just ty
+ || (spec_overloading && c)
+ = Just ty
| otherwise
- = Nothing
+ = Nothing
\end{code}
-@getIdOverloading@ grabs the type of an Id, and returns a
+@getIdOverloading@ grabs the type of an Id, and returns a
list of its polymorphic variables, and the initial segment of
its ThetaType, in which the classes constrain only type variables.
For example, if the Id's type is
This seems curious at first. For a start, the type above looks odd,
because we usually only have dictionary args whose types are of
the form (C a) where a is a type variable. But this doesn't hold for
-the functions arising from instance decls, which sometimes get
+the functions arising from instance decls, which sometimes get
arguements with types of form (C (T a)) for some type constructor T.
Should we specialise wrt this compound-type dictionary? This is
getIdOverloading id
= (tyvars, tyvar_part_of theta)
where
- (tyvars, theta, _) = splitType (getIdUniType id)
+ (tyvars, theta, _) = splitSigmaTy (idType id)
tyvar_part_of [] = []
tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
\begin{code}
type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
-mkConstraintVector :: Id
- -> ConstraintVector
+mkConstraintVector :: Id
+ -> ConstraintVector
mkConstraintVector id
= [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
\end{code}
\begin{code}
-isUnboxedSpecialisation :: [Maybe UniType] -> Bool
+isUnboxedSpecialisation :: [Maybe Type] -> Bool
isUnboxedSpecialisation tys
= any is_unboxed tys
where
specialised on. We only speciailise on unboxed types.
\begin{code}
-specialiseConstrTys :: [UniType]
- -> [Maybe UniType]
+specialiseConstrTys :: [Type]
+ -> [Maybe Type]
specialiseConstrTys tys
= map maybe_unboxed_ty tys
\end{code}
\begin{code}
-mkSpecialisedCon :: Id -> [UniType] -> Id
+mkSpecialisedCon :: Id -> [Type] -> Id
mkSpecialisedCon con tys
= if spec_reqd
then mkSameSpecCon spec_tys con
@argTysMatchSpecTys@ checks if a list of argument types is consistent
with a list of specialising types. An error message is returned if not.
\begin{code}
-argTysMatchSpecTys_error :: [Maybe UniType]
- -> [UniType]
+argTysMatchSpecTys_error :: [Maybe Type]
+ -> [Type]
-> Maybe Pretty
argTysMatchSpecTys_error spec_tys arg_tys
= if match spec_tys arg_tys
then Nothing
else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:",
ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys],
- ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]])
+ ppStr "argtys=", ppSep [pprParendType PprDebug ty | ty <- arg_tys]])
where
match (Nothing:spec_tys) (arg:arg_tys)
= not (isUnboxedDataType arg) &&
- match spec_tys arg_tys
+ match spec_tys arg_tys
match (Just spec:spec_tys) (arg:arg_tys)
= case (cmpUniType True{-properly-} spec arg) of
- EQ_ -> match spec_tys arg_tys
- other -> False
+ EQ_ -> match spec_tys arg_tys
+ other -> False
match [] [] = True
match _ _ = False
\end{code}
\begin{code}
pprSpecErrs :: FAST_STRING -- module name
- -> (Bag (Id,[Maybe UniType])) -- errors
- -> (Bag (Id,[Maybe UniType])) -- warnings
- -> (Bag (TyCon,[Maybe UniType])) -- errors
+ -> (Bag (Id,[Maybe Type])) -- errors
+ -> (Bag (Id,[Maybe Type])) -- warnings
+ -> (Bag (TyCon,[Maybe Type])) -- errors
-> Pretty
pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
= ppAboves [
ppStr "SPECIALISATION MESSAGES:",
ppAboves (map pp_module_specs use_modules)
- ]
+ ]
where
any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
any_warn = not (isEmptyBag spec_warn)
mk_module_fm get_mod_data errs_bag
= addListToFM_C (++) emptyFM errs_list
where
- errs_list = map get_mod_data (bagToList errs_bag)
+ errs_list = map get_mod_data (bagToList errs_bag)
tyspecs_fm = mk_module_fm get_ty_data spec_tyerrs
from_prelude mod
= SLIT("Prelude") == (_SUBSTR_ mod 0 6)
-
+
module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
mods = map head (equivClasses _CMP_STRING_ module_names)
else case _CMP_STRING_ (head mods) _NIL_ of
EQ_ -> ([_NIL_], tail mods)
other -> ([], mods)
-
+
(prels, others) = partition from_prelude known
use_modules = unks ++ prels ++ others
= ppNil
where
- mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
- mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
+ mod_tyspecs = lookupWithDefaultFM tyspecs_fm [] mod
+ mod_idspecs = lookupWithDefaultFM idspecs_fm [] mod
have_specs = not (null mod_tyspecs && null mod_idspecs)
- ty_sty = PprInterface (error "SpecTyFuns:PprInterface:sw_chkr")
+ ty_sty = PprInterface (error "SpecUtils:PprInterface:sw_chkr")
pp_module mod
= ppBesides [ppPStr mod, ppStr ":"]
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty
+pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
pp_tyspec sty pp_mod (_, tycon, tys)
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE", ppStr "data",
- pprNonOp PprForUser tycon, ppCat (map (pprParendUniType sty) spec_tys),
+ pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
ppStr "#-}", ppStr "{- Essential -}"
- ]
+ ]
where
tvs = getTyConTyVarTemplates tycon
(spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
choose_ty (tv, Just ty) = (ty, Nothing)
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe UniType], Bool) -> Pretty
+pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
pp_idspec sty pp_mod (_, id, tys, is_err)
| isDictFunId id
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
ppStr "instance",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-}", pp_essential ]
| is_const_method_id
ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pp_clsop clsop_str, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-} {- IN instance",
- ppPStr cls_str, pprParendUniType sty clsty,
+ ppPStr cls_str, pprParendType sty clsty,
ppStr "-}", pp_essential ]
| is_default_method_id
ppPStr cls_str,
ppStr "EXPLICIT METHOD REQUIRED",
pp_clsop clsop_str, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "-}", pp_essential ]
| otherwise
= ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
pprNonOp PprForUser id, ppStr "::",
- pprUniType sty spec_ty,
+ pprType sty spec_ty,
ppStr "#-}", pp_essential ]
where
- spec_ty = specialiseTy (getIdUniType id) tys 100 -- HACK to drop all dicts!!!
+ spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
const_method_maybe = isConstMethodId_maybe id
projects / ghc-hetmet.git / blobdiff