X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecUtils.lhs;h=7fc03524920bf7e8563bb412e944df2f579c008c;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=bd7ec63d06df63d8546164ad964db31a7e5a8b2b;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index bd7ec63..7fc0352 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -4,13 +4,10 @@ \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} \begin{code} -#include "HsVersions.h" - module SpecUtils ( specialiseCallTys, - SYN_IE(ConstraintVector), + ConstraintVector, getIdOverloading, - mkConstraintVector, isUnboxedSpecialisation, specialiseConstrTys, @@ -21,62 +18,76 @@ module SpecUtils ( pprSpecErrs ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import Bag ( isEmptyBag, bagToList ) -import Class ( classOpString, GenClass{-instance NamedThing-} ) +import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, + opt_SpecialiseAll + ) +import Bag ( isEmptyBag, bagToList, Bag ) +import Class ( Class ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) -import Id ( idType, isDictFunId, isConstMethodId_maybe, - isDefaultMethodId_maybe, - GenId {-instance NamedThing -} - ) +import Id ( Id ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( origName, isLexVarSym, isLexSpecialSym, pprNonSym ) -import PprStyle ( PprStyle(..) ) -import PprType ( pprGenType, pprParendGenType, pprMaybeTy, - TyCon{-ditto-}, GenType{-ditto-}, GenTyVar - ) -import Pretty -- plenty of it -import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) -import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys, - getTyVar_maybe, isUnboxedType +import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) ) +import Outputable +import PprType ( pprParendType, pprMaybeTy, TyCon ) +import TyCon ( tyConTyVars ) +import Type ( mkSigmaTy, instantiateTauTy, instantiateThetaTy, + splitSigmaTy, mkTyVarTy, mkForAllTys, + isUnboxedType, Type ) -import TyVar ( GenTyVar{-instance Eq-} ) -import Unique ( Unique{-instance Eq-} ) -import Util ( equivClasses, zipWithEqual, cmpPString, +import TyVar ( TyVar, mkTyVarEnv ) +import Util ( equivClasses, zipWithEqual, 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)" +mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)" \end{code} + +\begin{code} +specialiseTy :: Type -- The type of the Id of which the SpecId + -- is a specialised version + -> [Maybe Type] -- The types at which it is specialised + -> Int -- Number of leading dictionary args to ignore + -> Type + +specialiseTy main_ty maybe_tys dicts_to_ignore + = mkSigmaTy remaining_tyvars + (instantiateThetaTy inst_env remaining_theta) + (instantiateTauTy inst_env tau) + where + (tyvars, theta, tau) = splitSigmaTy main_ty -- A prefix of, but usually all, + -- the theta is discarded! + remaining_theta = drop dicts_to_ignore theta + tyvars_and_maybe_tys = tyvars `zip` maybe_tys + remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys] + inst_env = mkTyVarEnv [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys] +\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 @@ -106,6 +117,11 @@ gained by specialising wrt them. \begin{code} getIdOverloading :: Id -> ([TyVar], [(Class,TyVar)]) +getIdOverloading = panic "getIdOverloading" + +-- Looks suspicious to me; and I'm not sure what corresponds to +-- (Class,TyVar) pairs in the multi-param type class world. +{- getIdOverloading id = (tyvars, tyvar_part_of theta) where @@ -115,19 +131,11 @@ getIdOverloading id 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} @@ -170,20 +178,20 @@ with a list of specialising types. An error message is returned if not. \begin{code} argTysMatchSpecTys_error :: [Maybe Type] -> [Type] - -> Maybe Pretty + -> Maybe SDoc 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 ty | ty <- spec_tys], + ptext SLIT("argtys="), sep [pprParendType ty | ty <- arg_tys]]) where match (Nothing:spec_tys) (arg:arg_tys) = not (isUnboxedType arg) && match spec_tys arg_tys match (Just spec:spec_tys) (arg:arg_tys) = case (cmpType True{-properly-} spec arg) of - EQ_ -> match spec_tys arg_tys + EQ -> match spec_tys arg_tys other -> False match [] [] = True match _ _ = False @@ -197,16 +205,16 @@ pprSpecErrs :: FAST_STRING -- module name -> (Bag (Id,[Maybe Type])) -- errors -> (Bag (Id,[Maybe Type])) -- warnings -> (Bag (TyCon,[Maybe Type])) -- errors - -> Pretty + -> SDoc 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) @@ -228,7 +236,10 @@ 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_) @@ -238,55 +249,55 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs in (use_mod, _NIL_) | otherwise - = case (origName "get_id_name" id) of { OrigName m n -> (m, n) } +-} + = modAndOcc id get_ty_data (ty, tys) = (mod_name, [(ty_name, ty, tys)]) where - (OrigName mod_name ty_name) = origName "get_ty_data" ty + (mod_name, ty_name) = modAndOcc ty module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm] - mods = map head (equivClasses _CMP_STRING_ module_names) + mods = map head (equivClasses compare module_names) (unks, known) = if null mods then ([], []) - else case _CMP_STRING_ (head mods) _NIL_ of - EQ_ -> ([_NIL_], tail mods) + else case head mods `compare` _NIL_ of + EQ -> ([_NIL_], tail mods) other -> ([], mods) use_modules = unks ++ known - pp_module_specs :: FAST_STRING -> Pretty + pp_module_specs :: FAST_STRING -> SDoc pp_module_specs mod | mod == _NIL_ = ASSERT (null mod_tyspecs) - ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs) + vcat (map (pp_idspec (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 (pp_module mod)) mod_tyspecs), + vcat (map (pp_idspec (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 pp_module mod - = ppBesides [ppPStr mod, ppStr ":"] + = hcat [ptext mod, char ':'] -pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty +pp_tyspec :: SDoc -> (OccName, TyCon, [Maybe Type]) -> SDoc -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 -}" +pp_tyspec pp_mod (_, tycon, tys) + = hsep [pp_mod, + text "{-# SPECIALIZE data", + ppr tycon, hsep (map pprParendType spec_tys), + text "-} {- Essential -}" ] where tvs = tyConTyVars tycon @@ -296,53 +307,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 :: SDoc -> (OccName, Id, [Maybe Type], Bool) -> SDoc +pp_idspec = error "pp_idspec" + +{- LATER -pp_idspec sty pp_mod (_, id, tys, is_err) +pp_idspec pp_mod (_, id, tys, is_err) | isDictFunId id - = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - ppStr "instance", - pprGenType sty spec_ty, - ppStr "#-}", pp_essential ] + = hsep [pp_mod, + text "{-# SPECIALIZE instance", + pprGenType spec_ty, + text "#-}", pp_essential ] | is_const_method_id = let Just (cls, clsty, clsop) = const_method_maybe - (OrigName _ cls_str) = origName "pp_idspec" cls - clsop_str = classOpString clsop in - ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - pp_clsop clsop_str, ppStr "::", - pprGenType sty spec_ty, - ppStr "#-} {- IN instance", - ppPStr cls_str, pprParendGenType sty clsty, - ppStr "-}", pp_essential ] + hsep [pp_mod, + text "{-# SPECIALIZE", + ppr clsop, text "::", + pprGenType spec_ty, + text "#-} {- IN instance", + pprOccName (getOccName cls), pprParendType clsty, + text "-}", pp_essential ] | is_default_method_id = let Just (cls, clsop, _) = default_method_maybe - (OrigName _ cls_str) = origName "pp_idspec2" cls - clsop_str = classOpString clsop in - ppCat [pp_mod, - ppStr "{- instance", - ppPStr cls_str, - ppStr "EXPLICIT METHOD REQUIRED", - pp_clsop clsop_str, ppStr "::", - pprGenType sty spec_ty, - ppStr "-}", pp_essential ] + hsep [pp_mod, + text "{- instance", + pprOccName (getOccName cls), + ptext SLIT("EXPLICIT METHOD REQUIRED"), + ppr clsop, text "::", + pprGenType spec_ty, + text "-}", pp_essential ] | otherwise - = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - pprNonSym PprForUser id, ppStr "::", - pprGenType sty spec_ty, - ppStr "#-}", pp_essential ] + = hsep [pp_mod, + text "{-# SPECIALIZE", + ppr id, ptext SLIT("::"), + pprGenType 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 @@ -350,9 +359,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}