X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecUtils.lhs;h=574ef8ef40cc4550e56577d9eabb1a4773852002;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=c360e6104cb170eb691be55c89543527d0a7b134;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index c360e61..574ef8e 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,10 +20,13 @@ module SpecUtils ( pprSpecErrs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, + opt_SpecialiseAll + ) import Bag ( isEmptyBag, bagToList ) -import Class ( getClassOpString, GenClass{-instance NamedThing-} ) +import Class ( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) @@ -33,7 +35,7 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, GenId {-instance NamedThing -} ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Outputable ( isAvarop, pprNonOp ) +import Name ( OccName, pprNonSym, pprOccName, modAndOcc ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar @@ -60,23 +62,19 @@ specialiseTy = panic "SpecUtils.specialiseTy (ToDo)" 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 +specialiseCallTys :: 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 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 @@ -119,15 +117,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} @@ -174,9 +163,9 @@ argTysMatchSpecTys_error :: [Maybe Type] 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 (ppSep [ppPStr SLIT("Spec and Arg Types Inconsistent:"), + ppPStr SLIT("spectys="), ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys], + ppPStr SLIT("argtys="), ppSep [pprParendGenType PprDebug ty | ty <- arg_tys]]) where match (Nothing:spec_tys) (arg:arg_tys) = not (isUnboxedType arg) && @@ -205,7 +194,7 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs | otherwise = ppAboves [ - ppStr "SPECIALISATION MESSAGES:", + ppPStr SLIT("SPECIALISATION MESSAGES:"), ppAboves (map pp_module_specs use_modules) ] where @@ -228,27 +217,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 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) @@ -259,14 +247,13 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs 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 mod | mod == _NIL_ = ASSERT (null mod_tyspecs) - ppAboves (map (pp_idspec ty_sty (ppStr "UNKNOWN:")) mod_idspecs) + ppAboves (map (pp_idspec ty_sty (ppPStr SLIT("UNKNOWN:"))) mod_idspecs) | have_specs = ppAboves [ @@ -284,15 +271,15 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs ty_sty = PprInterface pp_module mod - = ppBesides [ppPStr mod, ppStr ":"] + = ppBesides [ppPStr mod, ppChar ':'] -pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty +pp_tyspec :: PprStyle -> Pretty -> (OccName, TyCon, [Maybe Type]) -> Pretty pp_tyspec sty pp_mod (_, tycon, tys) = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", ppStr "data", - pprNonOp PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), - ppStr "#-}", ppStr "{- Essential -}" + ppStr "{-# SPECIALIZE data", + pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), + ppStr "-} {- Essential -}" ] where tvs = tyConTyVars tycon @@ -302,48 +289,43 @@ 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 -> Pretty -> (OccName, Id, [Maybe Type], Bool) -> Pretty pp_idspec sty pp_mod (_, id, tys, is_err) | isDictFunId id = ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - ppStr "instance", + ppStr "{-# SPECIALIZE instance", pprGenType sty spec_ty, ppStr "#-}", 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 "::", + pprNonSym sty clsop, ppStr "::", pprGenType sty spec_ty, ppStr "#-} {- IN instance", - ppPStr cls_str, pprParendGenType sty clsty, + pprOccName sty (getOccName cls), pprParendGenType sty clsty, ppStr "-}", 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 "::", + pprOccName sty (getOccName cls), + ppPStr SLIT("EXPLICIT METHOD REQUIRED"), + pprNonSym sty clsop, ppStr "::", pprGenType sty spec_ty, ppStr "-}", pp_essential ] | otherwise = ppCat [pp_mod, ppStr "{-# SPECIALIZE", - pprNonOp PprForUser id, ppStr "::", + pprNonSym PprForUser id, ppPStr SLIT("::"), pprGenType sty spec_ty, ppStr "#-}", pp_essential ] where @@ -355,10 +337,4 @@ 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 | isAvarop str - = ppBesides [ppLparen, ppPStr str, ppRparen] - | otherwise - = ppPStr str - \end{code}