From: sof Date: Sun, 18 May 1997 23:16:13 +0000 (+0000) Subject: [project @ 1997-05-18 23:16:13 by sof] X-Git-Tag: Approximately_1000_patches_recorded~613 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=322ffb934144468f8a2d92ce72951f57abc0632c;p=ghc-hetmet.git [project @ 1997-05-18 23:16:13 by sof] new PP;2.0x bootable --- diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 574ef8e..e2eec02 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -25,32 +25,37 @@ IMP_Ubiq(){-uitous-} import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, opt_SpecialiseAll ) -import Bag ( isEmptyBag, bagToList ) -import Class ( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} ) +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 ( idType, isDictFunId, isConstMethodId_maybe, isDefaultMethodId_maybe, - GenId {-instance NamedThing -} + GenId {-instance NamedThing -}, SYN_IE(Id) ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Name ( OccName, pprNonSym, pprOccName, modAndOcc ) +import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, - TyCon{-ditto-}, GenType{-ditto-}, GenTyVar + 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 + 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-} ) +#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)" @@ -63,8 +68,8 @@ based on flags, the overloading constraint vector, and the types. \begin{code} specialiseCallTys :: ConstraintVector -- Tells which type args are overloaded - -> [Type] -- Type args - -> [Maybe Type] -- Nothings replace non-specialised type args + -> [Type] -- Type args + -> [Maybe Type] -- Nothings replace non-specialised type args specialiseCallTys cvec tys | opt_SpecialiseAll = map Just tys @@ -73,8 +78,8 @@ specialiseCallTys cvec tys spec_ty_other c ty | (opt_SpecialiseUnboxed && isUnboxedType ty) || (opt_SpecialiseOverloaded && c) = Just ty + | otherwise = Nothing - | otherwise = Nothing \end{code} @getIdOverloading@ grabs the type of an Id, and returns a @@ -159,13 +164,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 [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]]) + 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) && @@ -186,16 +191,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 [ - ppPStr SLIT("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) @@ -249,20 +254,20 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs 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 (ppPStr SLIT("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 @@ -271,15 +276,15 @@ pprSpecErrs this_mod spec_errs spec_warn spec_tyerrs ty_sty = PprInterface pp_module mod - = ppBesides [ppPStr mod, ppChar ':'] + = hcat [ptext mod, char ':'] -pp_tyspec :: PprStyle -> Pretty -> (OccName, 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 data", - pprNonSym PprForUser tycon, ppCat (map (pprParendGenType sty) spec_tys), - ppStr "-} {- Essential -}" + = hsep [pp_mod, + text "{-# SPECIALIZE data", + ppr PprForUser tycon, hsep (map (pprParendGenType sty) spec_tys), + text "-} {- Essential -}" ] where tvs = tyConTyVars tycon @@ -289,48 +294,48 @@ 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 -> (OccName, 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 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 in - ppCat [pp_mod, - ppStr "{-# SPECIALIZE", - pprNonSym sty clsop, ppStr "::", + hsep [pp_mod, + text "{-# SPECIALIZE", + ppr sty clsop, text "::", pprGenType sty spec_ty, - ppStr "#-} {- IN instance", + text "#-} {- IN instance", pprOccName sty (getOccName cls), pprParendGenType sty clsty, - ppStr "-}", pp_essential ] + text "-}", pp_essential ] | is_default_method_id = let Just (cls, clsop, _) = default_method_maybe in - ppCat [pp_mod, - ppStr "{- instance", + hsep [pp_mod, + text "{- instance", pprOccName sty (getOccName cls), - ppPStr SLIT("EXPLICIT METHOD REQUIRED"), - pprNonSym sty clsop, ppStr "::", + 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, ppPStr SLIT("::"), + = hsep [pp_mod, + text "{-# SPECIALIZE", + ppr PprForUser 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