X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecUtils.lhs;h=49335982f52dfcfe9862bbddbbef44921a9829ad;hb=e3b67289ad773d37576e763704baaca6b83d74db;hp=7af0cc7eb7e461d1f54f6a1b2df23b99e08ccb85;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 7af0cc7..4933598 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -8,9 +8,8 @@ module SpecUtils ( specialiseCallTys, - ConstraintVector(..), + SYN_IE(ConstraintVector), getIdOverloading, - mkConstraintVector, isUnboxedSpecialisation, specialiseConstrTys, @@ -21,63 +20,59 @@ module SpecUtils ( pprSpecErrs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import Bag ( isEmptyBag, bagToList ) -import Class ( classOpString, GenClass{-instance NamedThing-} ) +import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, + opt_SpecialiseAll, opt_PprUserLength + ) +import Bag ( isEmptyBag, bagToList, Bag ) +import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class) ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) -import Id ( idType, isDictFunId, isConstMethodId_maybe, - isDefaultMethodId_maybe, - GenId {-instance NamedThing -} +import Id ( idType, isDictFunId, + isDefaultMethodId_maybe, mkSameSpecCon, + GenId {-instance NamedThing -}, SYN_IE(Id) ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( isLexVarSym, isLexSpecialSym, pprNonSym, moduleNamePair ) -import PprStyle ( PprStyle(..) ) +import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) ) +import Outputable ( PprStyle(..), Outputable(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar ) -import PrelMods ( fromPrelude, pRELUDE ) import Pretty -- plenty of it import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, - getTyVar_maybe, isUnboxedType + getTyVar_maybe, isUnboxedType, SYN_IE(Type) ) -import TyVar ( GenTyVar{-instance Eq-} ) +import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) import Unique ( Unique{-instance Eq-} ) import Util ( equivClasses, zipWithEqual, cmpPString, assertPanic, panic{-ToDo:rm-} ) + 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 "specialiseCallTys" 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 && isUnboxedType 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 @@ -120,15 +115,6 @@ getIdOverloading id \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} @@ -171,13 +157,13 @@ with a list of specialising types. An error message is returned if not. \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 [pprParendGenType 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 (isUnboxedType arg) && @@ -198,16 +184,16 @@ pprSpecErrs :: FAST_STRING -- module name -> (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) @@ -229,24 +215,26 @@ pprSpecErrs this_mod spec_errs spec_warn 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 fromPrelude get_mod - then pRELUDE - else get_mod + use_mod = get_mod in (use_mod, _NIL_) | otherwise - = moduleNamePair id +-} + = modAndOcc id get_ty_data (ty, tys) = (mod_name, [(ty_name, ty, tys)]) where - (mod_name,ty_name) = moduleNamePair ty + (mod_name, ty_name) = modAndOcc ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] mods = map head (equivClasses _CMP_STRING_ module_names) @@ -257,23 +245,22 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs EQ_ -> ([_NIL_], tail mods) other -> ([], mods) - (prels, others) = partition fromPrelude 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 @@ -282,15 +269,15 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs 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", - pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), - ppStr "#-}", ppStr "{- Essential -}" + = hsep [pp_mod, + text "{-# SPECIALIZE data", + ppr (PprForUser opt_PprUserLength) tycon, hsep (map (pprParendGenType sty) spec_tys), + text "-} {- Essential -}" ] where tvs = tyConTyVars tycon @@ -300,53 +287,51 @@ pp_tyspec sty pp_mod (_, tycon, tys) 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 = error "pp_idspec" + +{- LATER pp_idspec sty pp_mod (_, id, tys, is_err) | isDictFunId id - = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - ppStr "instance", + = hsep [pp_mod, + text "{-# SPECIALIZE instance", pprGenType sty spec_ty, - ppStr "#-}", pp_essential ] + text "#-}", pp_essential ] | is_const_method_id = let Just (cls, clsty, clsop) = const_method_maybe - (_, cls_str) = moduleNamePair cls - clsop_str = classOpString clsop in - ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - pp_clsop clsop_str, ppStr "::", + hsep [pp_mod, + text "{-# SPECIALIZE", + ppr sty clsop, text "::", pprGenType sty spec_ty, - ppStr "#-} {- IN instance", - ppPStr cls_str, pprParendGenType sty clsty, - ppStr "-}", pp_essential ] + 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) = moduleNamePair cls - clsop_str = classOpString clsop in - ppCat [pp_mod, - ppStr "{- instance", - ppPStr cls_str, - ppStr "EXPLICIT METHOD REQUIRED", - pp_clsop clsop_str, ppStr "::", + hsep [pp_mod, + text "{- instance", + pprOccName sty (getOccName cls), + ptext SLIT("EXPLICIT METHOD REQUIRED"), + ppr sty clsop, text "::", pprGenType sty spec_ty, - ppStr "-}", pp_essential ] + text "-}", pp_essential ] | otherwise - = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - pprNonSym PprForUser id, ppStr "::", + = hsep [pp_mod, + text "{-# SPECIALIZE", + ppr (PprForUser opt_PprUserLength) id, ptext SLIT("::"), pprGenType sty spec_ty, - ppStr "#-}", pp_essential ] + 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 @@ -354,9 +339,5 @@ pp_idspec sty pp_mod (_, id, tys, is_err) default_method_maybe = isDefaultMethodId_maybe id is_default_method_id = maybeToBool default_method_maybe - pp_clsop str | isLexVarSym str && not (isLexSpecialSym str) - = ppParens (ppPStr str) - | otherwise - = ppPStr str - +-} \end{code}