%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
module SpecUtils (
specialiseCallTys,
- ConstraintVector(..),
+ SYN_IE(ConstraintVector),
getIdOverloading,
- mkConstraintVector,
isUnboxedSpecialisation,
specialiseConstrTys,
pprSpecErrs
) where
-import Type
-import Bag ( Bag, isEmptyBag, bagToList )
-import FiniteMap ( FiniteMap, emptyFM, addListToFM_C,
- plusFM_C, keysFM, lookupWithDefaultFM
+IMP_Ubiq(){-uitous-}
+
+import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
+ opt_SpecialiseAll
+ )
+import Bag ( isEmptyBag, bagToList, Bag )
+import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class),
+ GenClassOp {- instance NamedThing -} )
+import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
+ lookupWithDefaultFM
)
-import Id ( mkSameSpecCon, idType,
- isDictFunId, isConstMethodId_maybe,
+import Id ( idType, isDictFunId, isConstMethodId_maybe,
isDefaultMethodId_maybe,
- getInstIdModule, Id )
-import Maybes
-import Outputable
-import Pretty
-import Util
+ GenId {-instance NamedThing -}, SYN_IE(Id)
+ )
+import Maybes ( maybeToBool, catMaybes, firstJust )
+import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) )
+import PprStyle ( PprStyle(..) )
+import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
+ TyCon{-ditto-}, GenType{-ditto-}, GenTyVar, GenClassOp
+ )
+import Pretty -- plenty of it
+import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
+import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys,
+ getTyVar_maybe, isUnboxedType, SYN_IE(Type)
+ )
+import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
+import Unique ( Unique{-instance Eq-} )
+import Util ( equivClasses, zipWithEqual, cmpPString,
+ assertPanic, panic{-ToDo:rm-}
+ )
+
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable ( Outputable(..) )
+#endif
+
+cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
+mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
+getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
+specialiseTy :: Type -> [Maybe Type] -> Int -> Type
+specialiseTy = panic "SpecUtils.specialiseTy (ToDo)"
\end{code}
@specialiseCallTys@ works out which type args don't need to be specialised on,
based on flags, the overloading constraint vector, and the types.
\begin{code}
-specialiseCallTys :: Bool -- Specialise on all type args
- -> Bool -- Specialise on unboxed type args
- -> Bool -- Specialise on overloaded type args
- -> ConstraintVector -- Tells which type args are overloaded
- -> [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
- = zipWithEqual spec_ty_other cvec tys
+specialiseCallTys :: ConstraintVector -- Tells which type args are overloaded
+ -> [Type] -- Type args
+ -> [Maybe Type] -- Nothings replace non-specialised type args
+
+specialiseCallTys cvec tys
+ | opt_SpecialiseAll = map Just tys
+ | otherwise = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys
where
- spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty)
- || (spec_overloading && c)
- = Just ty
- | otherwise
- = Nothing
+ spec_ty_other c ty | (opt_SpecialiseUnboxed && isUnboxedType ty) ||
+ (opt_SpecialiseOverloaded && c)
+ = Just ty
+ | otherwise = Nothing
+
\end{code}
@getIdOverloading@ grabs the type of an Id, and returns a
\begin{code}
getIdOverloading :: Id
- -> ([TyVarTemplate], [(Class,TyVarTemplate)])
+ -> ([TyVar], [(Class,TyVar)])
getIdOverloading id
= (tyvars, tyvar_part_of theta)
where
(tyvars, theta, _) = splitSigmaTy (idType id)
- tyvar_part_of [] = []
- tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
- Nothing -> []
- Just tyvar -> (clas, tyvar) : tyvar_part_of theta
+ tyvar_part_of [] = []
+ tyvar_part_of ((c,ty):theta) = case (getTyVar_maybe ty) of
+ Nothing -> []
+ Just tv -> (c, tv) : tyvar_part_of theta
\end{code}
\begin{code}
type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise
-
-mkConstraintVector :: Id
- -> ConstraintVector
-
-mkConstraintVector id
- = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
- where
- (tyvars, class_tyvar_pairs) = getIdOverloading id
- constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
\end{code}
\begin{code}
isUnboxedSpecialisation tys
= any is_unboxed tys
where
- is_unboxed (Just ty) = isUnboxedDataType ty
+ is_unboxed (Just ty) = isUnboxedType ty
is_unboxed Nothing = False
\end{code}
specialiseConstrTys tys
= map maybe_unboxed_ty tys
where
- maybe_unboxed_ty ty = case isUnboxedDataType ty of
+ maybe_unboxed_ty ty = case isUnboxedType ty of
True -> Just ty
False -> Nothing
\end{code}
\begin{code}
argTysMatchSpecTys_error :: [Maybe Type]
-> [Type]
- -> Maybe Pretty
+ -> Maybe Doc
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 [pprParendType PprDebug ty | ty <- arg_tys]])
+ else Just (sep [ptext SLIT("Spec and Arg Types Inconsistent:"),
+ ptext SLIT("spectys="), sep [pprMaybeTy PprDebug ty | ty <- spec_tys],
+ ptext SLIT("argtys="), sep [pprParendGenType PprDebug ty | ty <- arg_tys]])
where
match (Nothing:spec_tys) (arg:arg_tys)
- = not (isUnboxedDataType arg) &&
+ = not (isUnboxedType arg) &&
match spec_tys arg_tys
match (Just spec:spec_tys) (arg:arg_tys)
- = case (cmpUniType True{-properly-} spec arg) of
+ = case (cmpType True{-properly-} spec arg) of
EQ_ -> match spec_tys arg_tys
other -> False
match [] [] = True
-> (Bag (Id,[Maybe Type])) -- errors
-> (Bag (Id,[Maybe Type])) -- warnings
-> (Bag (TyCon,[Maybe Type])) -- errors
- -> Pretty
+ -> Doc
pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs
| not any_errs && not any_warn
- = ppNil
+ = empty
| otherwise
- = ppAboves [
- ppStr "SPECIALISATION MESSAGES:",
- ppAboves (map pp_module_specs use_modules)
+ = vcat [
+ ptext SLIT("SPECIALISATION MESSAGES:"),
+ vcat (map pp_module_specs use_modules)
]
where
any_errs = not (isEmptyBag spec_errs && isEmptyBag spec_tyerrs)
where
(mod_name, id_name) = get_id_name id
+
get_id_name id
+
+{- Don't understand this -- and looks TURGID. SLPJ 4 Nov 96
| maybeToBool (isDefaultMethodId_maybe id)
= (this_mod, _NIL_)
| isDictFunId id || maybeToBool (isConstMethodId_maybe id)
= let get_mod = getInstIdModule id
- use_mod = if from_prelude get_mod
- then SLIT("Prelude")
- else get_mod
+ use_mod = get_mod
in (use_mod, _NIL_)
| otherwise
- = getOrigName id
+-}
+ = modAndOcc id
get_ty_data (ty, tys)
= (mod_name, [(ty_name, ty, tys)])
where
- (mod_name,ty_name) = getOrigName ty
-
- from_prelude mod
- = SLIT("Prelude") == (_SUBSTR_ mod 0 6)
+ (mod_name, ty_name) = modAndOcc ty
module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
mods = map head (equivClasses _CMP_STRING_ module_names)
EQ_ -> ([_NIL_], tail mods)
other -> ([], mods)
- (prels, others) = partition from_prelude known
- use_modules = unks ++ prels ++ others
+ use_modules = unks ++ known
- pp_module_specs :: FAST_STRING -> Pretty
+ pp_module_specs :: FAST_STRING -> Doc
pp_module_specs mod
| mod == _NIL_
= ASSERT (null mod_tyspecs)
- ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs)
+ vcat (map (pp_idspec ty_sty (ptext SLIT("UNKNOWN:"))) mod_idspecs)
| have_specs
- = ppAboves [
- ppAboves (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
- ppAboves (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
+ = vcat [
+ vcat (map (pp_tyspec ty_sty (pp_module mod)) mod_tyspecs),
+ vcat (map (pp_idspec ty_sty (pp_module mod)) mod_idspecs)
]
| otherwise
- = ppNil
+ = empty
where
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 "SpecUtils:PprInterface:sw_chkr")
+ ty_sty = PprInterface
pp_module mod
- = ppBesides [ppPStr mod, ppStr ":"]
+ = hcat [ptext mod, char ':']
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
+pp_tyspec :: PprStyle -> Doc -> (OccName, TyCon, [Maybe Type]) -> Doc
pp_tyspec sty pp_mod (_, tycon, tys)
- = ppCat [pp_mod,
- ppStr "{-# SPECIALIZE", ppStr "data",
- pprNonOp PprForUser tycon, ppCat (map (pprParendType sty) spec_tys),
- ppStr "#-}", ppStr "{- Essential -}"
+ = hsep [pp_mod,
+ text "{-# SPECIALIZE data",
+ ppr PprForUser tycon, hsep (map (pprParendGenType sty) spec_tys),
+ text "-} {- Essential -}"
]
where
- tvs = getTyConTyVarTemplates tycon
+ tvs = tyConTyVars tycon
(spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys))
- spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args
+ spec_tys = map (mkForAllTys (catMaybes tv_maybes)) spec_args
- choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv)
+ choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
choose_ty (tv, Just ty) = (ty, Nothing)
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
+pp_idspec :: PprStyle -> Doc -> (OccName, Id, [Maybe Type], Bool) -> Doc
pp_idspec sty pp_mod (_, id, tys, is_err)
| isDictFunId id
- = ppCat [pp_mod,
- ppStr "{-# SPECIALIZE",
- ppStr "instance",
- pprType sty spec_ty,
- ppStr "#-}", pp_essential ]
+ = hsep [pp_mod,
+ text "{-# SPECIALIZE instance",
+ pprGenType sty spec_ty,
+ text "#-}", pp_essential ]
| is_const_method_id
= let
Just (cls, clsty, clsop) = const_method_maybe
- (_, cls_str) = getOrigName cls
- clsop_str = getClassOpString clsop
in
- ppCat [pp_mod,
- ppStr "{-# SPECIALIZE",
- pp_clsop clsop_str, ppStr "::",
- pprType sty spec_ty,
- ppStr "#-} {- IN instance",
- ppPStr cls_str, pprParendType sty clsty,
- ppStr "-}", pp_essential ]
+ hsep [pp_mod,
+ text "{-# SPECIALIZE",
+ ppr sty clsop, text "::",
+ pprGenType sty spec_ty,
+ text "#-} {- IN instance",
+ pprOccName sty (getOccName cls), pprParendGenType sty clsty,
+ text "-}", pp_essential ]
| is_default_method_id
= let
Just (cls, clsop, _) = default_method_maybe
- (_, cls_str) = getOrigName cls
- clsop_str = getClassOpString clsop
in
- ppCat [pp_mod,
- ppStr "{- instance",
- ppPStr cls_str,
- ppStr "EXPLICIT METHOD REQUIRED",
- pp_clsop clsop_str, ppStr "::",
- pprType sty spec_ty,
- ppStr "-}", pp_essential ]
+ hsep [pp_mod,
+ text "{- instance",
+ pprOccName sty (getOccName cls),
+ ptext SLIT("EXPLICIT METHOD REQUIRED"),
+ ppr sty clsop, text "::",
+ pprGenType sty spec_ty,
+ text "-}", pp_essential ]
| otherwise
- = ppCat [pp_mod,
- ppStr "{-# SPECIALIZE",
- pprNonOp PprForUser id, ppStr "::",
- pprType sty spec_ty,
- ppStr "#-}", pp_essential ]
+ = hsep [pp_mod,
+ text "{-# SPECIALIZE",
+ ppr PprForUser id, ptext SLIT("::"),
+ pprGenType sty spec_ty,
+ text "#-}", pp_essential ]
where
spec_ty = specialiseTy (idType id) tys 100 -- HACK to drop all dicts!!!
- pp_essential = if is_err then ppStr "{- Essential -}" else ppNil
+ pp_essential = if is_err then text "{- Essential -}" else empty
const_method_maybe = isConstMethodId_maybe id
is_const_method_id = maybeToBool const_method_maybe
default_method_maybe = isDefaultMethodId_maybe id
is_default_method_id = maybeToBool default_method_maybe
-
- pp_clsop str | isAvarop str
- = ppBesides [ppLparen, ppPStr str, ppRparen]
- | otherwise
- = ppPStr str
-
\end{code}
projects / ghc-hetmet.git / blobdiff