From dcef38bab91d45b56f7cf3ceeec96303d93728bb Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 19 May 1997 00:21:27 +0000 Subject: [PATCH] [project @ 1997-05-19 00:12:10 by sof] 2.04 changes --- ghc/compiler/absCSyn/AbsCLoop.hs | 12 + ghc/compiler/absCSyn/AbsCSyn.lhs | 10 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 66 +-- ghc/compiler/absCSyn/CLabel.hi-boot | 5 + ghc/compiler/absCSyn/CLabel.lhs | 102 ++-- ghc/compiler/absCSyn/CStrings.lhs | 57 +-- ghc/compiler/absCSyn/HeapOffs.lhs | 45 +- ghc/compiler/absCSyn/PprAbsC.lhs | 654 ++++++++++++------------ ghc/compiler/basicTypes/Demand.lhs | 4 +- ghc/compiler/basicTypes/FieldLabel.hi-boot | 5 + ghc/compiler/basicTypes/FieldLabel.lhs | 7 +- ghc/compiler/basicTypes/Id.hi-boot | 13 +- ghc/compiler/basicTypes/Id.lhs | 190 ++++--- ghc/compiler/basicTypes/IdInfo.lhs | 71 ++- ghc/compiler/basicTypes/IdLoop.hs | 16 + ghc/compiler/basicTypes/IdLoop.lhi | 17 +- ghc/compiler/basicTypes/IdUtils.lhs | 4 +- ghc/compiler/basicTypes/Literal.hi-boot | 5 + ghc/compiler/basicTypes/Literal.lhs | 42 +- ghc/compiler/basicTypes/Name.hi-boot | 8 + ghc/compiler/basicTypes/Name.lhs | 107 ++-- ghc/compiler/basicTypes/PprEnv.lhs | 66 ++- ghc/compiler/basicTypes/PragmaInfo.lhs | 6 + ghc/compiler/basicTypes/SrcLoc.lhs | 29 +- ghc/compiler/basicTypes/UniqSupply.lhs | 23 +- ghc/compiler/basicTypes/Unique.hi-boot | 6 + ghc/compiler/basicTypes/Unique.lhs | 50 +- ghc/compiler/codeGen/CGLoop1.hs | 1 + ghc/compiler/codeGen/CgBindery.hi-boot | 12 + ghc/compiler/codeGen/CgBindery.lhs | 17 +- ghc/compiler/codeGen/CgCase.lhs | 13 +- ghc/compiler/codeGen/CgClosure.lhs | 20 +- ghc/compiler/codeGen/CgCon.lhs | 4 +- ghc/compiler/codeGen/CgConTbls.lhs | 11 +- ghc/compiler/codeGen/CgExpr.hi-boot | 6 + ghc/compiler/codeGen/CgExpr.lhs | 43 +- ghc/compiler/codeGen/CgHeapery.lhs | 4 +- ghc/compiler/codeGen/CgLetNoEscape.lhs | 3 +- ghc/compiler/codeGen/CgLoop1.hs | 9 + ghc/compiler/codeGen/CgLoop2.hs | 7 + ghc/compiler/codeGen/CgMonad.lhs | 26 +- ghc/compiler/codeGen/CgRetConv.hi-boot | 7 + ghc/compiler/codeGen/CgRetConv.lhs | 7 +- ghc/compiler/codeGen/CgTailCall.lhs | 5 +- ghc/compiler/codeGen/CgUsages.hi-boot | 5 + ghc/compiler/codeGen/ClosureInfo.hi-boot | 18 + ghc/compiler/codeGen/ClosureInfo.lhs | 41 +- ghc/compiler/codeGen/CodeGen.lhs | 5 + ghc/compiler/codeGen/SMRep.lhs | 7 +- ghc/compiler/coreSyn/AnnCoreSyn.lhs | 7 + ghc/compiler/coreSyn/CoreLift.lhs | 3 +- ghc/compiler/coreSyn/CoreLint.lhs | 134 ++--- ghc/compiler/coreSyn/CoreSyn.lhs | 12 +- ghc/compiler/coreSyn/CoreUnfold.hi-boot | 8 + ghc/compiler/coreSyn/CoreUnfold.lhs | 262 +++++----- ghc/compiler/coreSyn/CoreUtils.lhs | 19 +- ghc/compiler/coreSyn/FreeVars.lhs | 6 +- ghc/compiler/coreSyn/PprCore.lhs | 200 ++++---- ghc/compiler/deSugar/Desugar.lhs | 41 +- ghc/compiler/deSugar/DsBinds.hi-boot | 5 + ghc/compiler/deSugar/DsBinds.lhs | 557 +++----------------- ghc/compiler/deSugar/DsCCall.lhs | 8 +- ghc/compiler/deSugar/DsExpr.hi-boot | 5 + ghc/compiler/deSugar/DsExpr.lhs | 87 ++-- ghc/compiler/deSugar/DsGRHSs.lhs | 63 ++- ghc/compiler/deSugar/DsHsSyn.lhs | 14 +- ghc/compiler/deSugar/DsListComp.lhs | 3 +- ghc/compiler/deSugar/DsLoop.hs | 12 + ghc/compiler/deSugar/DsMonad.lhs | 92 ++-- ghc/compiler/deSugar/DsUtils.lhs | 196 +++---- ghc/compiler/deSugar/Match.hi-boot | 6 + ghc/compiler/deSugar/Match.lhs | 28 +- ghc/compiler/deSugar/MatchCon.lhs | 2 +- ghc/compiler/deSugar/MatchLit.lhs | 4 +- ghc/compiler/deforest/Cyclic.lhs | 10 +- ghc/compiler/deforest/Def2Core.lhs | 2 +- ghc/compiler/deforest/DefExpr.lhs | 6 +- ghc/compiler/deforest/DefUtils.lhs | 4 +- ghc/compiler/deforest/Deforest.lhs | 10 +- ghc/compiler/hsSyn/HsBasic.lhs | 31 +- ghc/compiler/hsSyn/HsBinds.hi-boot | 10 + ghc/compiler/hsSyn/HsBinds.lhs | 276 +++++----- ghc/compiler/hsSyn/HsCore.lhs | 51 +- ghc/compiler/hsSyn/HsDecls.lhs | 180 ++++--- ghc/compiler/hsSyn/HsExpr.hi-boot | 11 + ghc/compiler/hsSyn/HsExpr.lhs | 174 +++---- ghc/compiler/hsSyn/HsImpExp.lhs | 30 +- ghc/compiler/hsSyn/HsLoop.hs | 9 + ghc/compiler/hsSyn/HsLoop.lhi | 11 +- ghc/compiler/hsSyn/HsMatches.lhs | 49 +- ghc/compiler/hsSyn/HsPat.lhs | 77 +-- ghc/compiler/hsSyn/HsPragmas.lhs | 70 +-- ghc/compiler/hsSyn/HsSyn.lhs | 29 +- ghc/compiler/hsSyn/HsTypes.lhs | 37 +- ghc/compiler/main/CmdLineOpts.lhs | 36 +- ghc/compiler/main/ErrUtils.lhs | 27 +- ghc/compiler/main/Main.lhs | 67 +-- ghc/compiler/main/MkIface.lhs | 286 +++++++---- ghc/compiler/nativeGen/AbsCStixGen.lhs | 5 + ghc/compiler/nativeGen/AsmCodeGen.lhs | 21 +- ghc/compiler/nativeGen/AsmRegAlloc.lhs | 4 + ghc/compiler/nativeGen/MachCode.lhs | 96 ++-- ghc/compiler/nativeGen/MachMisc.hi-boot | 8 + ghc/compiler/nativeGen/MachMisc.lhs | 56 +- ghc/compiler/nativeGen/MachRegs.lhs | 23 +- ghc/compiler/nativeGen/NcgLoop.hs | 12 + ghc/compiler/nativeGen/PprMach.lhs | 766 ++++++++++++++-------------- ghc/compiler/nativeGen/RegAllocInfo.lhs | 11 +- ghc/compiler/nativeGen/Stix.hi-boot | 5 + ghc/compiler/nativeGen/Stix.lhs | 11 +- ghc/compiler/nativeGen/StixInfo.lhs | 20 +- ghc/compiler/nativeGen/StixInteger.lhs | 4 + ghc/compiler/nativeGen/StixMacro.lhs | 4 + ghc/compiler/nativeGen/StixPrim.hi-boot | 5 + ghc/compiler/nativeGen/StixPrim.lhs | 12 +- ghc/compiler/parser/UgenAll.lhs | 4 + ghc/compiler/parser/UgenUtil.lhs | 11 +- ghc/compiler/parser/constr.ugn | 4 + ghc/compiler/parser/hsparser.y | 94 ++-- ghc/compiler/parser/pbinding.ugn | 3 +- ghc/compiler/parser/syntax.c | 1 + ghc/compiler/prelude/PrelInfo.lhs | 34 +- ghc/compiler/prelude/PrelLoop.hs | 1 + ghc/compiler/prelude/PrelMods.lhs | 5 - ghc/compiler/prelude/PrelVals.lhs | 37 +- ghc/compiler/prelude/PrimOp.hi-boot | 5 + ghc/compiler/prelude/PrimOp.lhs | 27 +- ghc/compiler/prelude/PrimRep.lhs | 10 +- ghc/compiler/prelude/StdIdInfo.hi-boot | 5 + ghc/compiler/prelude/StdIdInfo.lhs | 32 +- ghc/compiler/prelude/TysPrim.hi-boot | 5 + ghc/compiler/prelude/TysPrim.lhs | 4 +- ghc/compiler/prelude/TysWiredIn.hi-boot | 6 + ghc/compiler/prelude/TysWiredIn.lhs | 20 +- ghc/compiler/profiling/CostCentre.hi-boot | 16 + ghc/compiler/profiling/CostCentre.lhs | 99 ++-- ghc/compiler/profiling/SCCfinal.lhs | 5 +- ghc/compiler/reader/Lex.lhs | 54 +- ghc/compiler/reader/PrefixSyn.lhs | 3 +- ghc/compiler/reader/PrefixToHs.lhs | 6 +- ghc/compiler/reader/RdrHsSyn.lhs | 21 +- ghc/compiler/reader/ReadPrefix.lhs | 120 +++-- ghc/compiler/rename/ParseIface.y | 46 +- ghc/compiler/rename/ParseType.y | 27 +- ghc/compiler/rename/ParseUnfolding.y | 52 +- ghc/compiler/rename/Rename.lhs | 131 +++-- ghc/compiler/rename/RnBinds.hi-boot | 5 + ghc/compiler/rename/RnBinds.lhs | 139 +++-- ghc/compiler/rename/RnEnv.lhs | 134 +++-- ghc/compiler/rename/RnExpr.lhs | 141 +++-- ghc/compiler/rename/RnHsSyn.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 450 +++++++++++----- ghc/compiler/rename/RnLoop.hs | 10 + ghc/compiler/rename/RnLoop.lhi | 9 +- ghc/compiler/rename/RnMonad.lhs | 51 +- ghc/compiler/rename/RnNames.lhs | 156 +++--- ghc/compiler/rename/RnSource.hi-boot | 8 + ghc/compiler/rename/RnSource.lhs | 296 ++++++----- 158 files changed, 4669 insertions(+), 3843 deletions(-) create mode 100644 ghc/compiler/absCSyn/AbsCLoop.hs create mode 100644 ghc/compiler/absCSyn/CLabel.hi-boot create mode 100644 ghc/compiler/basicTypes/FieldLabel.hi-boot create mode 100644 ghc/compiler/basicTypes/IdLoop.hs create mode 100644 ghc/compiler/basicTypes/Literal.hi-boot create mode 100644 ghc/compiler/basicTypes/Name.hi-boot create mode 100644 ghc/compiler/basicTypes/Unique.hi-boot create mode 100644 ghc/compiler/codeGen/CGLoop1.hs create mode 100644 ghc/compiler/codeGen/CgBindery.hi-boot create mode 100644 ghc/compiler/codeGen/CgExpr.hi-boot create mode 100644 ghc/compiler/codeGen/CgLoop1.hs create mode 100644 ghc/compiler/codeGen/CgLoop2.hs create mode 100644 ghc/compiler/codeGen/CgRetConv.hi-boot create mode 100644 ghc/compiler/codeGen/CgUsages.hi-boot create mode 100644 ghc/compiler/codeGen/ClosureInfo.hi-boot create mode 100644 ghc/compiler/coreSyn/CoreUnfold.hi-boot create mode 100644 ghc/compiler/deSugar/DsBinds.hi-boot create mode 100644 ghc/compiler/deSugar/DsExpr.hi-boot create mode 100644 ghc/compiler/deSugar/DsLoop.hs create mode 100644 ghc/compiler/deSugar/Match.hi-boot create mode 100644 ghc/compiler/hsSyn/HsBinds.hi-boot create mode 100644 ghc/compiler/hsSyn/HsExpr.hi-boot create mode 100644 ghc/compiler/hsSyn/HsLoop.hs create mode 100644 ghc/compiler/nativeGen/MachMisc.hi-boot create mode 100644 ghc/compiler/nativeGen/NcgLoop.hs create mode 100644 ghc/compiler/nativeGen/Stix.hi-boot create mode 100644 ghc/compiler/nativeGen/StixPrim.hi-boot create mode 100644 ghc/compiler/prelude/PrelLoop.hs create mode 100644 ghc/compiler/prelude/PrimOp.hi-boot create mode 100644 ghc/compiler/prelude/StdIdInfo.hi-boot create mode 100644 ghc/compiler/prelude/TysPrim.hi-boot create mode 100644 ghc/compiler/prelude/TysWiredIn.hi-boot create mode 100644 ghc/compiler/profiling/CostCentre.hi-boot create mode 100644 ghc/compiler/rename/RnBinds.hi-boot create mode 100644 ghc/compiler/rename/RnLoop.hs create mode 100644 ghc/compiler/rename/RnSource.hi-boot diff --git a/ghc/compiler/absCSyn/AbsCLoop.hs b/ghc/compiler/absCSyn/AbsCLoop.hs new file mode 100644 index 0000000..48e9ad1 --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCLoop.hs @@ -0,0 +1,12 @@ +module AbsCLoop + ( + module MachMisc, + module CLabel, + module ClosureInfo, + module CgRetConv + )where + +import MachMisc +import CLabel +import ClosureInfo +import CgRetConv diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 28cab79..96411a1 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -36,6 +36,7 @@ module AbsCSyn {- ( )-} where IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) import Constants ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG, lIVENESS_R1, lIVENESS_R2, @@ -43,10 +44,15 @@ import Constants ( mAX_Vanilla_REG, mAX_Float_REG, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 ) import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), - SYN_IE(VirtualHeapOffset) + SYN_IE(VirtualHeapOffset), HeapOffset ) -import Literal ( mkMachInt ) +import CLabel ( CLabel ) +import CostCentre ( CostCentre ) +import Literal ( mkMachInt, Literal ) import PrimRep ( isFollowableRep, PrimRep(..) ) +import PrimOp ( PrimOp ) +import Unique ( Unique ) + \end{code} @AbstractC@ is a list of Abstract~C statements, but the data structure diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 65742ea..35a43d1 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -23,15 +23,15 @@ IMP_Ubiq(){-uitous-} import AbsCSyn -import CLabel ( mkReturnPtLabel ) -import Digraph ( stronglyConnComp ) +import CLabel ( mkReturnPtLabel, CLabel ) +import Digraph ( stronglyConnComp, SCC(..) ) import HeapOffs ( possiblyEqualHeapOffset ) import Id ( fIRST_TAG, SYN_IE(ConTag) ) import Literal ( literalPrimRep, Literal(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) -import UniqSupply ( getUnique, getUniques, splitUniqSupply ) -import Util ( panic ) +import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) +import Util ( assocDefaultUsing, panic, Ord3(..) ) infixr 9 `thenFlt` \end{code} @@ -628,38 +628,22 @@ sameAmode other1 other2 = False doSimultaneously1 :: [CVertex] -> FlatM AbstractC doSimultaneously1 vertices = let - edges :: [CEdge] - edges = concat (map edges_from vertices) - - edges_from :: CVertex -> [CEdge] - edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2] - - should_follow :: CVertex -> CVertex -> Bool - (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2) - = dest1 `conflictsWith` src2 - (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2) - = or [dest1 `conflictsWith` src2 | dest1 <- dests1] - (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _) - = or [dest1 `conflictsWith` src2 | src2 <- srcs2] - (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _) - = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] - --- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False --- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False - - eq_vertex :: CVertex -> CVertex -> Bool - (n1, _) `eq_vertex` (n2, _) = n1 == n2 - - components = stronglyConnComp eq_vertex edges vertices + edges = [ (vertex, key1, edges_from stmt1) + | vertex@(key1, stmt1) <- vertices + ] + edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, + stmt1 `should_follow` stmt2 + ] + components = stronglyConnComp edges -- do_components deal with one strongly-connected component - do_component :: [CVertex] -> FlatM AbstractC - - -- A singleton? Then just do it. - do_component [(n,abs_c)] = returnFlt abs_c + -- Not cyclic, or singleton? Just do it + do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c + do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c - -- Two or more? Then go via temporaries. - do_component ((n,first_stmt):rest) + -- Cyclic? Then go via temporaries. Pick one to + -- break the loop and try again with the rest. + do_component (CyclicSCC ((n,first_stmt) : rest)) = doSimultaneously1 rest `thenFlt` \ abs_cs -> go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) -> returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps]) @@ -681,6 +665,22 @@ doSimultaneously1 vertices in mapFlt do_component components `thenFlt` \ abs_cs -> returnFlt (mkAbstractCs abs_cs) + + where + should_follow :: AbstractC -> AbstractC -> Bool + (CAssign dest1 _) `should_follow` (CAssign _ src2) + = dest1 `conflictsWith` src2 + (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2) + = or [dest1 `conflictsWith` src2 | dest1 <- dests1] + (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _) + = or [dest1 `conflictsWith` src2 | src2 <- srcs2] + (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _) + = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] + +-- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False +-- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False + + \end{code} diff --git a/ghc/compiler/absCSyn/CLabel.hi-boot b/ghc/compiler/absCSyn/CLabel.hi-boot new file mode 100644 index 0000000..8b64303 --- /dev/null +++ b/ghc/compiler/absCSyn/CLabel.hi-boot @@ -0,0 +1,5 @@ +_interface_ CLabel 1 +_exports_ +CLabel CLabel; +_declarations_ +1 data CLabel; diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 7c9444c..ef14727 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -61,16 +61,20 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon, isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - SYN_IE(ConTag), GenId{-instance Outputable-} + SYN_IE(ConTag), GenId{-instance Outputable-}, + SYN_IE(Id) ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( showTyCon, GenType{-instance Outputable-} ) -import Pretty ( prettyToUn{-, ppPStr ToDo:rm-} ) import TyCon ( TyCon{-instance Eq-} ) import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) -import Unpretty -- NOTE!! ******************** -import Util ( assertPanic{-, pprTraceToDo:rm-} ) +import Pretty +import Util ( assertPanic{-, pprTraceToDo:rm-}, Ord3(..) ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif + \end{code} things we want to find out: @@ -316,92 +320,92 @@ duplicate declarations in generating C (see @labelSeenTE@ in pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) #endif -pprCLabel :: PprStyle -> CLabel -> Unpretty +pprCLabel :: PprStyle -> CLabel -> Doc pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) - = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) + = text (fmtAsmLbl (_UNPK_ (showUnique u))) pprCLabel (PprForAsm prepend_cSEP _) lbl = if prepend_cSEP - then uppBeside pp_cSEP prLbl + then (<>) pp_cSEP prLbl else prLbl where prLbl = pprCLabel PprForC lbl pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, - pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, + pp_cSEP, ptext SLIT("upd")] pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, - uppInt tag, pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, + int tag, pp_cSEP, ptext SLIT("upd")] pprCLabel sty (TyConLabel tc (StdUpdCode tag)) = case (ctrlReturnConvAlg tc) of - UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir") - VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) + UnvectoredReturn _ -> ptext SLIT("IndUpdRetDir") + VectoredReturn _ -> (<>) (ptext SLIT("IndUpdRetV")) (int (tag - fIRST_TAG)) pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")] + = hcat [ppr_tycon sty tc, pp_cSEP, ptext SLIT("itblvtbl")] pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, - pp_cSEP, uppPStr SLIT("upd")] + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, + pp_cSEP, ptext SLIT("upd")] pprCLabel sty (CaseLabel u CaseReturnPt) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("ret"), pp_cSEP, ppr_u u] pprCLabel sty (CaseLabel u CaseVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("vtbl"), pp_cSEP, ppr_u u] pprCLabel sty (CaseLabel u (CaseAlt tag)) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag] + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, int tag] pprCLabel sty (CaseLabel u CaseDefault) - = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u] + = hcat [ptext SLIT("djn"), pp_cSEP, ppr_u u] -pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode") +pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("StdErrorCode") -pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") +pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = ptext SLIT("BH_UPD_info") pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), - uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), - uppPStr SLIT("__")] + = hcat [ptext SLIT("__sel_info_"), text (show offset), + ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), + ptext SLIT("__")] pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), - uppPStr (if upd_reqd then SLIT("upd") else SLIT("noupd")), - uppPStr SLIT("__")] + = hcat [ptext SLIT("__sel_entry_"), text (show offset), + ptext (if upd_reqd then SLIT("upd") else SLIT("noupd")), + ptext SLIT("__")] pprCLabel sty (IdLabel (CLabelId id) flavor) - = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor) + = (<>) (ppr sty id) (ppFlavor flavor) -ppr_u u = prettyToUn (pprUnique u) +ppr_u u = pprUnique u ppr_tycon sty tc = let str = showTyCon sty tc in - --pprTrace "ppr_tycon:" (ppStr str) $ - uppStr str + --pprTrace "ppr_tycon:" (text str) $ + text str -ppFlavor :: IdLabelInfo -> Unpretty +ppFlavor :: IdLabelInfo -> Doc -ppFlavor x = uppBeside pp_cSEP +ppFlavor x = (<>) pp_cSEP (case x of - Closure -> uppPStr SLIT("closure") - InfoTbl -> uppPStr SLIT("info") - EntryStd -> uppPStr SLIT("entry") + Closure -> ptext SLIT("closure") + InfoTbl -> ptext SLIT("info") + EntryStd -> ptext SLIT("entry") EntryFast arity -> --false:ASSERT (arity > 0) - uppBeside (uppPStr SLIT("fast")) (uppInt arity) - StaticClosure -> uppPStr SLIT("static_closure") - ConEntry -> uppPStr SLIT("con_entry") - ConInfoTbl -> uppPStr SLIT("con_info") - StaticConEntry -> uppPStr SLIT("static_entry") - StaticInfoTbl -> uppPStr SLIT("static_info") - PhantomInfoTbl -> uppPStr SLIT("inregs_info") - VapInfoTbl True -> uppPStr SLIT("vap_info") - VapInfoTbl False -> uppPStr SLIT("vap_noupd_info") - VapEntry True -> uppPStr SLIT("vap_entry") - VapEntry False -> uppPStr SLIT("vap_noupd_entry") - RednCounts -> uppPStr SLIT("ct") + (<>) (ptext SLIT("fast")) (int arity) + StaticClosure -> ptext SLIT("static_closure") + ConEntry -> ptext SLIT("con_entry") + ConInfoTbl -> ptext SLIT("con_info") + StaticConEntry -> ptext SLIT("static_entry") + StaticInfoTbl -> ptext SLIT("static_info") + PhantomInfoTbl -> ptext SLIT("inregs_info") + VapInfoTbl True -> ptext SLIT("vap_info") + VapInfoTbl False -> ptext SLIT("vap_noupd_info") + VapEntry True -> ptext SLIT("vap_entry") + VapEntry False -> ptext SLIT("vap_noupd_entry") + RednCounts -> ptext SLIT("ct") ) \end{code} diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index ea5e3d1..964623a 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -17,13 +17,8 @@ module CStrings( CHK_Ubiq() -- debugging consistency check import Pretty -import Unpretty( uppChar ) -IMPORT_1_3(Char (isAlphanum)) -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -chr = toEnum :: Int -> Char -#endif +IMPORT_1_3(Char (isAlphanum,ord,chr)) \end{code} @@ -42,9 +37,9 @@ Prelude ZP \begin{code} cSEP = SLIT("_") -- official C separator -pp_cSEP = uppChar '_' +pp_cSEP = char '_' -identToC :: FAST_STRING -> Pretty +identToC :: FAST_STRING -> Doc modnameToC :: FAST_STRING -> FAST_STRING stringToC :: String -> String charToC, charToEasyHaskell :: Char -> String @@ -105,36 +100,36 @@ identToC ps = let str = _UNPK_ ps in - ppBeside + (<>) (case str of 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"... - ppChar 'Z' - _ -> ppNil) + char 'Z' + _ -> empty) (if (all isAlphanum str) -- we gamble that this test will succeed... - then ppPStr ps - else ppIntersperse ppNil (map char_to_c str)) + then ptext ps + else hcat (map char_to_c str)) where - char_to_c 'Z' = ppPStr SLIT("ZZ") - char_to_c '&' = ppPStr SLIT("Za") - char_to_c '|' = ppPStr SLIT("Zb") - char_to_c ':' = ppPStr SLIT("Zc") - char_to_c '/' = ppPStr SLIT("Zd") - char_to_c '=' = ppPStr SLIT("Ze") - char_to_c '>' = ppPStr SLIT("Zg") - char_to_c '#' = ppPStr SLIT("Zh") - char_to_c '<' = ppPStr SLIT("Zl") - char_to_c '-' = ppPStr SLIT("Zm") - char_to_c '!' = ppPStr SLIT("Zn") - char_to_c '.' = ppPStr SLIT("_") - char_to_c '+' = ppPStr SLIT("Zp") - char_to_c '\'' = ppPStr SLIT("Zq") - char_to_c '*' = ppPStr SLIT("Zt") - char_to_c '_' = ppPStr SLIT("Zu") + char_to_c 'Z' = ptext SLIT("ZZ") + char_to_c '&' = ptext SLIT("Za") + char_to_c '|' = ptext SLIT("Zb") + char_to_c ':' = ptext SLIT("Zc") + char_to_c '/' = ptext SLIT("Zd") + char_to_c '=' = ptext SLIT("Ze") + char_to_c '>' = ptext SLIT("Zg") + char_to_c '#' = ptext SLIT("Zh") + char_to_c '<' = ptext SLIT("Zl") + char_to_c '-' = ptext SLIT("Zm") + char_to_c '!' = ptext SLIT("Zn") + char_to_c '.' = ptext SLIT("_") + char_to_c '+' = ptext SLIT("Zp") + char_to_c '\'' = ptext SLIT("Zq") + char_to_c '*' = ptext SLIT("Zt") + char_to_c '_' = ptext SLIT("Zu") char_to_c c = if isAlphanum c - then ppChar c - else ppBeside (ppChar 'Z') (ppInt (ord c)) + then char c + else (<>) (char 'Z') (int (ord c)) \end{code} For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index ee58c6f..efc8414 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -38,8 +38,9 @@ IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) import Maybes ( catMaybes ) import SMRep -import Unpretty -- ********** NOTE ********** +import Pretty -- ********** NOTE ********** import Util ( panic ) +import PprStyle ( PprStyle ) \end{code} %************************************************************************ @@ -264,19 +265,19 @@ print either a single value, or a parenthesised value. No need for the caller to parenthesise. \begin{code} -pprHeapOffset :: PprStyle -> HeapOffset -> Unpretty +pprHeapOffset :: PprStyle -> HeapOffset -> Doc -pprHeapOffset sty ZeroHeapOffset = uppChar '0' +pprHeapOffset sty ZeroHeapOffset = char '0' pprHeapOffset sty (MaxHeapOffset off1 off2) - = uppBeside (uppPStr SLIT("STG_MAX")) - (uppParens (uppBesides [pprHeapOffset sty off1, uppComma, pprHeapOffset sty off2])) + = (<>) (ptext SLIT("STG_MAX")) + (parens (hcat [pprHeapOffset sty off1, comma, pprHeapOffset sty off2])) pprHeapOffset sty (AddHeapOffset off1 off2) - = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '+', + = parens (hcat [pprHeapOffset sty off1, char '+', pprHeapOffset sty off2]) pprHeapOffset sty (SubHeapOffset off1 off2) - = uppParens (uppBesides [pprHeapOffset sty off1, uppChar '-', + = parens (hcat [pprHeapOffset sty off1, char '-', pprHeapOffset sty off2]) pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) @@ -289,44 +290,44 @@ pprHeapOffsetPieces :: PprStyle -> FAST_INT -- Fixed hdrs -> [SMRep__Int] -- Var hdrs -> [SMRep__Int] -- Tot hdrs - -> Unpretty + -> Doc -pprHeapOffsetPieces sty n ILIT(0) [] [] = uppInt IBOX(n) -- Deals with zero case too +pprHeapOffsetPieces sty n ILIT(0) [] [] = int IBOX(n) -- Deals with zero case too pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs = let pp_int_offs = if int_offs _EQ_ ILIT(0) then Nothing - else Just (uppInt IBOX(int_offs)) + else Just (int IBOX(int_offs)) pp_fxdhdr_offs = if fxdhdr_offs _EQ_ ILIT(0) then Nothing else if fxdhdr_offs _EQ_ ILIT(1) then - Just (uppPStr SLIT("_FHS")) + Just (ptext SLIT("_FHS")) else - Just (uppBesides [uppChar '(', uppPStr SLIT("_FHS*"), uppInt IBOX(fxdhdr_offs), uppChar ')']) + Just (hcat [char '(', ptext SLIT("_FHS*"), int IBOX(fxdhdr_offs), char ')']) - pp_varhdr_offs = pp_hdrs (uppPStr SLIT("_VHS")) varhdr_offs + pp_varhdr_offs = pp_hdrs (ptext SLIT("_VHS")) varhdr_offs - pp_tothdr_offs = pp_hdrs (uppPStr SLIT("_HS")) tothdr_offs + pp_tothdr_offs = pp_hdrs (ptext SLIT("_HS")) tothdr_offs in case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of - [] -> uppChar '0' + [] -> char '0' [pp] -> pp -- Each blob is parenthesised if necessary - pps -> uppParens (uppIntersperse (uppChar '+') pps) + pps -> parens (cat (punctuate (char '+') pps)) where pp_hdrs hdr_pp [] = Nothing - pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just (uppBeside (uppStr (show rep)) hdr_pp) - pp_hdrs hdr_pp hdrs = Just (uppParens (uppInterleave (uppChar '+') - (map (pp_hdr hdr_pp) hdrs))) + pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just ((<>) (text (show rep)) hdr_pp) + pp_hdrs hdr_pp hdrs = Just (parens (sep (punctuate (char '+') + (map (pp_hdr hdr_pp) hdrs)))) - pp_hdr :: Unpretty -> SMRep__Int -> Unpretty + pp_hdr :: Doc -> SMRep__Int -> Doc pp_hdr pp_str (SMRI(rep, n)) = if n _EQ_ ILIT(1) then - uppBeside (uppStr (show rep)) pp_str + (<>) (text (show rep)) pp_str else - uppBesides [uppInt IBOX(n), uppChar '*', uppStr (show rep), pp_str] + hcat [int IBOX(n), char '*', text (show rep), pp_str] \end{code} %************************************************************************ diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 7fba22e..dfbd75e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -22,7 +22,11 @@ IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo IMPORT_1_3(IO(Handle)) IMPORT_1_3(Char(isDigit,isPrint)) +#if __GLASGOW_HASKELL__ == 201 IMPORT_1_3(GHCbase(Addr(..)) ) -- to see innards +#elif __GLASGOW_HASKELL__ >= 202 +import GlaExts (Addr(..)) +#endif import AbsCSyn @@ -43,7 +47,7 @@ import HeapOffs ( isZeroOff, subOff, pprHeapOffset ) import Literal ( showLiteral, Literal(..) ) import Maybes ( maybeToBool, catMaybes ) import PprStyle ( PprStyle(..) ) -import Pretty ( prettyToUn ) +import Pretty import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) import PrimRep ( isFloatingRep, showPrimRep, PrimRep(..) ) import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, @@ -53,7 +57,7 @@ import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, SYN_IE(UniqSet) ) -import Unpretty -- ********** NOTE ********** +import Outputable ( printDoc ) import Util ( nOfThem, panic, assertPanic ) infixr 9 `thenTE` @@ -66,35 +70,27 @@ call to a cost evaluation function @GRAN_EXEC@. For that, \begin{code} writeRealC :: Handle -> AbstractC -> IO () - -writeRealC handle absC - = uppPutStr handle 80 ( - uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') - ) +writeRealC handle absC = printDoc LeftMode handle (pprAbsC PprForC absC (costs absC)) dumpRealC :: AbstractC -> String - -dumpRealC absC - = uppShow 80 ( - uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') - ) +dumpRealC absC = show (pprAbsC PprForC absC (costs absC)) \end{code} This emits the macro, which is used in GrAnSim to compute the total costs from a cost 5 tuple. %% HWL \begin{code} -emitMacro :: CostRes -> Unpretty +emitMacro :: CostRes -> Doc -- ToDo: Check a compile time flag to decide whether a macro should be emitted emitMacro (Cost (i,b,l,s,f)) - = uppBesides [ uppPStr SLIT("GRAN_EXEC"), uppChar '(', - uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, - uppInt s, uppComma, uppInt f, pp_paren_semi ] + = hcat [ ptext SLIT("GRAN_EXEC"), char '(', + int i, comma, int b, comma, int l, comma, + int s, comma, int f, pp_paren_semi ] \end{code} \begin{code} -pp_paren_semi = uppStr ");" +pp_paren_semi = text ");" -- --------------------------------------------------------------------------- -- New type: Now pprAbsC also takes the costs for evaluating the Abstract C @@ -102,10 +98,10 @@ pp_paren_semi = uppStr ");" -- which must be done before the return i.e. inside absC code) HWL -- --------------------------------------------------------------------------- -pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty +pprAbsC :: PprStyle -> AbstractC -> CostRes -> Doc -pprAbsC sty AbsCNop _ = uppNil -pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c) +pprAbsC sty AbsCNop _ = empty +pprAbsC sty (AbsCStmts s1 s2) c = ($$) (pprAbsC sty s1 c) (pprAbsC sty s2 c) pprAbsC sty (CClosureUpdInfo info) c = pprAbsC sty info c @@ -113,27 +109,27 @@ pprAbsC sty (CClosureUpdInfo info) c pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeRep dest) dest src pprAbsC sty (CJump target) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ]) - (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) + = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) + (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ]) pprAbsC sty (CFallThrough target) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ]) - (uppBesides [ uppStr jmp_lit, pprAmode sty target, pp_paren_semi ]) + = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CFallThrough */"-} ]) + (hcat [ text jmp_lit, pprAmode sty target, pp_paren_semi ]) -- -------------------------------------------------------------------------- -- Spit out GRAN_EXEC macro immediately before the return HWL pprAbsC sty (CReturn am return_info) c - = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ]) - (uppBesides [uppStr jmp_lit, target, pp_paren_semi ]) + = ($$) (hcat [emitMacro c {-WDP:, text "/* <---- CReturn */"-} ]) + (hcat [text jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> uppBesides [uppPStr SLIT("DIRECT"),uppChar '(', pprAmode sty am, uppRparen] + DirectReturn -> hcat [ptext SLIT("DIRECT"),char '(', pprAmode sty am, rparen] DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') - StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive - mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"] + StaticVectoredReturn n -> mk_vector (int n) -- Always positive + mk_vector x = hcat [parens (pprAmode sty am), brackets (text "RVREL" <> parens x)] -pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */") +pprAbsC sty (CSplitMarker) _ = ptext SLIT("/* SPLIT */") -- we optimise various degenerate cases of CSwitches. @@ -172,25 +168,25 @@ pprAbsC sty (CSwitch discrim alts deflt) c -- general case | isFloatingRep (getAmodeRep discrim) = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c | otherwise - = uppAboves [ - uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"], - uppNest 2 (uppAboves (map (ppr_alt sty) alts)), + = vcat [ + hcat [text "switch (", pp_discrim, text ") {"], + nest 2 (vcat (map (ppr_alt sty) alts)), (case (nonemptyAbsC deflt) of - Nothing -> uppNil + Nothing -> empty Just dc -> - uppNest 2 (uppAboves [uppPStr SLIT("default:"), + nest 2 (vcat [ptext SLIT("default:"), pprAbsC sty dc (c + switch_head_cost + costs dc), - uppPStr SLIT("break;")])), - uppChar '}' ] + ptext SLIT("break;")])), + char '}' ] where pp_discrim = pprAmode sty discrim ppr_alt sty (lit, absC) - = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'], - uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC)) - (uppPStr SLIT("break;"))) ] + = vcat [ hcat [ptext SLIT("case "), pprBasicLit sty lit, char ':'], + nest 2 (($$) (pprAbsC sty absC (c + switch_head_cost + costs absC)) + (ptext SLIT("break;"))) ] -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) @@ -212,7 +208,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ in case (ppr_vol_regs sty vol_regs) of { (pp_saves, pp_restores) -> if primOpNeedsWrapper op then - uppAboves [ pp_saves, + vcat [ pp_saves, the_op, pp_restores ] @@ -221,10 +217,10 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ } where ppr_op_call results args - = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen, - uppIntersperse uppComma (map ppr_op_result results), - if null results || null args then uppNil else uppComma, - uppIntersperse uppComma (map (pprAmode sty) args), + = hcat [ pprPrimOp sty op, lparen, + hcat (punctuate comma (map ppr_op_result results)), + if null results || null args then empty else comma, + hcat (punctuate comma (map (pprAmode sty) args)), pp_paren_semi ] ppr_op_result r = ppr_amode sty r @@ -232,78 +228,78 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ -- hence we can toss the provided cast... pprAbsC sty (CSimultaneous abs_c) c - = uppBesides [uppPStr SLIT("{{"), pprAbsC sty abs_c c, uppPStr SLIT("}}")] + = hcat [ptext SLIT("{{"), pprAbsC sty abs_c c, ptext SLIT("}}")] pprAbsC sty stmt@(CMacroStmt macro as) _ - = uppBesides [uppStr (show macro), uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting + = hcat [text (show macro), lparen, + hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] -- no casting pprAbsC sty stmt@(CCallProfCtrMacro op as) _ - = uppBesides [uppPStr op, uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] + = hcat [ptext op, lparen, + hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] pprAbsC sty stmt@(CCallProfCCMacro op as) _ - = uppBesides [uppPStr op, uppLparen, - uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] + = hcat [ptext op, lparen, + hcat (punctuate comma (map (ppr_amode sty) as)),pp_paren_semi] pprAbsC sty (CCodeBlock label abs_C) _ = ASSERT( maybeToBool(nonemptyAbsC abs_C) ) case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> - uppAboves [ - uppBesides [uppStr (if (externallyVisibleCLabel label) + vcat [ + hcat [text (if (externallyVisibleCLabel label) then "FN_(" -- abbreviations to save on output else "IFN_("), - pprCLabel sty label, uppStr ") {"], + pprCLabel sty label, text ") {"], case sty of - PprForC -> uppAbove pp_exts pp_temps - _ -> uppNil, - uppNest 8 (uppPStr SLIT("FB_")), - uppNest 8 (pprAbsC sty abs_C (costs abs_C)), - uppNest 8 (uppPStr SLIT("FE_")), - uppChar '}' ] + PprForC -> ($$) pp_exts pp_temps + _ -> empty, + nest 8 (ptext SLIT("FB_")), + nest 8 (pprAbsC sty abs_C (costs abs_C)), + nest 8 (ptext SLIT("FE_")), + char '}' ] } pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ - = uppBesides [ pp_init_hdr, uppStr "_HDR(", - ppr_amode sty (CAddr reg_rel), uppComma, - pprCLabel sty info_lbl, uppComma, - if_profiling sty (pprAmode sty cost_centre), uppComma, - pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ] + = hcat [ pp_init_hdr, text "_HDR(", + ppr_amode sty (CAddr reg_rel), comma, + pprCLabel sty info_lbl, comma, + if_profiling sty (pprAmode sty cost_centre), comma, + pprHeapOffset sty size, comma, int ptr_wds, pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info sm_rep = closureSMRep cl_info size = closureSizeWithoutFixedHdr cl_info ptr_wds = closurePtrsSize cl_info - pp_init_hdr = uppStr (if inplace_upd then + pp_init_hdr = text (if inplace_upd then getSMUpdInplaceHdrStr sm_rep else getSMInitHdrStr sm_rep) pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - uppAboves [ + vcat [ case sty of PprForC -> pp_exts - _ -> uppNil, - uppBesides [ - uppPStr SLIT("SET_STATIC_HDR"),uppChar '(', - pprCLabel sty closure_lbl, uppComma, - pprCLabel sty info_lbl, uppComma, - if_profiling sty (pprAmode sty cost_centre), uppComma, - ppLocalness closure_lbl, uppComma, + _ -> empty, + hcat [ + ptext SLIT("SET_STATIC_HDR"),char '(', + pprCLabel sty closure_lbl, comma, + pprCLabel sty info_lbl, comma, + if_profiling sty (pprAmode sty cost_centre), comma, + ppLocalness closure_lbl, comma, ppLocalnessMacro False{-for data-} info_lbl, - uppChar ')' + char ')' ], - uppNest 2 (uppBesides (map (ppr_item sty) amodes)), - uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)), - uppPStr SLIT("};") ] + nest 2 (hcat (map (ppr_item sty) amodes)), + nest 2 (hcat (map (ppr_item sty) padding_wds)), + ptext SLIT("};") ] } where info_lbl = infoTableLabelFromCI cl_info ppr_item sty item = if getAmodeRep item == VoidRep - then uppStr ", (W_) 0" -- might not even need this... - else uppBeside (uppStr ", (W_)") (ppr_amode sty item) + then text ", (W_) 0" -- might not even need this... + else (<>) (text ", (W_)") (ppr_amode sty item) padding_wds = if not (closureUpdReqd cl_info) then @@ -325,41 +321,41 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ -} pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _ - = uppAboves [ - uppBesides [ + = vcat [ + hcat [ pp_info_rep, - uppPStr SLIT("_ITBL"),uppChar '(', - pprCLabel sty info_lbl, uppComma, + ptext SLIT("_ITBL"),char '(', + pprCLabel sty info_lbl, comma, -- CONST_ITBL needs an extra label for -- the static version of the object. if isConstantRep sm_rep - then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma - else uppNil, + then (<>) (pprCLabel sty (closureLabelFromCI cl_info)) comma + else empty, - pprCLabel sty slow_lbl, uppComma, - pprAmode sty upd, uppComma, - uppInt liveness, uppComma, + pprCLabel sty slow_lbl, comma, + pprAmode sty upd, comma, + int liveness, comma, - pp_tag, uppComma, - pp_size, uppComma, - pp_ptr_wds, uppComma, + pp_tag, comma, + pp_size, comma, + pp_ptr_wds, comma, - ppLocalness info_lbl, uppComma, - ppLocalnessMacro True{-function-} slow_lbl, uppComma, + ppLocalness info_lbl, comma, + ppLocalnessMacro True{-function-} slow_lbl, comma, if is_selector - then uppBeside (uppInt select_word_i) uppComma - else uppNil, + then (<>) (int select_word_i) comma + else empty, - if_profiling sty pp_kind, uppComma, - if_profiling sty pp_descr, uppComma, + if_profiling sty pp_kind, comma, + if_profiling sty pp_descr, comma, if_profiling sty pp_type, - uppStr ");" + text ");" ], pp_slow, case maybe_fast of - Nothing -> uppNil + Nothing -> empty Just fast -> let stuff = CCodeBlock fast_lbl fast in pprAbsC sty stuff (costs stuff) ] @@ -370,7 +366,7 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven (slow_lbl, pp_slow) = case (nonemptyAbsC slow) of - Nothing -> (mkErrorStdEntryLabel, uppNil) + Nothing -> (mkErrorStdEntryLabel, empty) Just xx -> (entryLabelFromCI cl_info, let stuff = CCodeBlock slow_lbl xx in pprAbsC sty stuff (costs stuff)) @@ -380,77 +376,77 @@ pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liven (Just (_, select_word_i)) = maybe_selector pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep - = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep)) + = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep)) - pp_tag = uppInt (closureSemiTag cl_info) + pp_tag = int (closureSemiTag cl_info) is_phantom = isPhantomRep sm_rep pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always) - uppInt (closureNonHdrSize cl_info) + int (closureNonHdrSize cl_info) else if is_phantom then -- do not have sizes for these - uppNil + empty else pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info) pp_ptr_wds = if is_phantom then - uppNil + empty else - uppInt (closurePtrsSize cl_info) + int (closurePtrsSize cl_info) - pp_kind = uppStr (closureKind cl_info) - pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"'] - pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"'] + pp_kind = text (closureKind cl_info) + pp_descr = hcat [char '"', text (stringToC cl_descr), char '"'] + pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"'] pprAbsC sty (CRetVector lbl maybes deflt) c - = uppAboves [ uppPStr SLIT("{ // CRetVector (lbl????)"), - uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)), - uppStr "} /*default=*/ {", pprAbsC sty deflt c, - uppChar '}'] + = vcat [ ptext SLIT("{ // CRetVector (lbl????)"), + nest 8 (sep (map (ppr_maybe_amode sty) maybes)), + text "} /*default=*/ {", pprAbsC sty deflt c, + char '}'] where - ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/") + ppr_maybe_amode sty Nothing = ptext SLIT("/*default*/") ppr_maybe_amode sty (Just a) = pprAmode sty a pprAbsC sty stmt@(CRetUnVector label amode) _ - = uppBesides [uppPStr SLIT("UNVECTBL"),uppChar '(', pp_static, uppComma, pprCLabel sty label, uppComma, - pprAmode sty amode, uppRparen] + = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel sty label, comma, + pprAmode sty amode, rparen] where - pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static") + pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static") pprAbsC sty stmt@(CFlatRetVector label amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - uppAboves [ + vcat [ case sty of PprForC -> pp_exts - _ -> uppNil, - uppBesides [ppLocalness label, uppPStr SLIT(" W_ "), - pprCLabel sty label, uppStr "[] = {"], - uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)), - uppStr "};" ] } + _ -> empty, + hcat [ppLocalness label, ptext SLIT(" W_ "), + pprCLabel sty label, text "[] = {"], + nest 2 (sep (punctuate comma (map (ppr_item sty) amodes))), + text "};" ] } where - ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item) + ppr_item sty item = (<>) (text "(W_) ") (ppr_amode sty item) pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc \end{code} \begin{code} ppLocalness label - = uppBeside static const + = (<>) static const where - static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ") - const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const") + static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ") + const = if not (isReadOnly label) then empty else ptext SLIT("const") ppLocalnessMacro for_fun{-vs data-} clabel - = uppBesides [ uppChar (if externallyVisibleCLabel clabel then 'E' else 'I'), + = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'), if for_fun then - uppPStr SLIT("F_") + ptext SLIT("F_") else - uppBeside (uppPStr SLIT("D_")) + (<>) (ptext SLIT("D_")) (if isReadOnly clabel then - uppPStr SLIT("RO_") + ptext SLIT("RO_") else - uppNil)] + empty)] \end{code} \begin{code} @@ -466,9 +462,9 @@ non_void amode \end{code} \begin{code} -ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty) +ppr_vol_regs :: PprStyle -> [MagicId] -> (Doc, Doc) -ppr_vol_regs sty [] = (uppNil, uppNil) +ppr_vol_regs sty [] = (empty, empty) ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs ppr_vol_regs sty (r:rs) = let pp_reg = case r of @@ -476,8 +472,8 @@ ppr_vol_regs sty (r:rs) _ -> pprMagicId sty r (more_saves, more_restores) = ppr_vol_regs sty rs in - (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves, - uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores) + (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves, + ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores) -- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls, @@ -485,30 +481,30 @@ ppr_vol_regs sty (r:rs) -- other registers.) Just be *sure* BaseReg is OK before trying to do -- anything else. pp_basic_saves - = uppAboves [ - uppPStr SLIT("CALLER_SAVE_Base"), - uppPStr SLIT("CALLER_SAVE_SpA"), - uppPStr SLIT("CALLER_SAVE_SuA"), - uppPStr SLIT("CALLER_SAVE_SpB"), - uppPStr SLIT("CALLER_SAVE_SuB"), - uppPStr SLIT("CALLER_SAVE_Ret"), --- uppPStr SLIT("CALLER_SAVE_Activity"), - uppPStr SLIT("CALLER_SAVE_Hp"), - uppPStr SLIT("CALLER_SAVE_HpLim") ] + = vcat [ + ptext SLIT("CALLER_SAVE_Base"), + ptext SLIT("CALLER_SAVE_SpA"), + ptext SLIT("CALLER_SAVE_SuA"), + ptext SLIT("CALLER_SAVE_SpB"), + ptext SLIT("CALLER_SAVE_SuB"), + ptext SLIT("CALLER_SAVE_Ret"), +-- ptext SLIT("CALLER_SAVE_Activity"), + ptext SLIT("CALLER_SAVE_Hp"), + ptext SLIT("CALLER_SAVE_HpLim") ] pp_basic_restores - = uppAboves [ - uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first! - uppPStr SLIT("CALLER_RESTORE_SpA"), - uppPStr SLIT("CALLER_RESTORE_SuA"), - uppPStr SLIT("CALLER_RESTORE_SpB"), - uppPStr SLIT("CALLER_RESTORE_SuB"), - uppPStr SLIT("CALLER_RESTORE_Ret"), --- uppPStr SLIT("CALLER_RESTORE_Activity"), - uppPStr SLIT("CALLER_RESTORE_Hp"), - uppPStr SLIT("CALLER_RESTORE_HpLim"), - uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"), - uppPStr SLIT("CALLER_RESTORE_StkStub") ] + = vcat [ + ptext SLIT("CALLER_RESTORE_Base"), -- must be first! + ptext SLIT("CALLER_RESTORE_SpA"), + ptext SLIT("CALLER_RESTORE_SuA"), + ptext SLIT("CALLER_RESTORE_SpB"), + ptext SLIT("CALLER_RESTORE_SuB"), + ptext SLIT("CALLER_RESTORE_Ret"), +-- ptext SLIT("CALLER_RESTORE_Activity"), + ptext SLIT("CALLER_RESTORE_Hp"), + ptext SLIT("CALLER_RESTORE_HpLim"), + ptext SLIT("CALLER_RESTORE_StdUpdRetVec"), + ptext SLIT("CALLER_RESTORE_StkStub") ] \end{code} \begin{code} @@ -516,7 +512,7 @@ if_profiling sty pretty = case sty of PprForC -> if opt_SccProfilingOn then pretty - else uppChar '0' -- leave it out! + else char '0' -- leave it out! _ -> {-print it anyway-} pretty @@ -535,8 +531,8 @@ do_if_stmt sty discrim tag alt_code deflt c deflt alt_code (addrModeCosts discrim Rhs) c other -> let - cond = uppBesides [ pprAmode sty discrim, - uppPStr SLIT(" == "), + cond = hcat [ pprAmode sty discrim, + ptext SLIT(" == "), pprAmode sty (CLit tag) ] in ppr_if_stmt sty cond @@ -544,16 +540,16 @@ do_if_stmt sty discrim tag alt_code deflt c (addrModeCosts discrim Rhs) c ppr_if_stmt sty pp_pred then_part else_part discrim_costs c - = uppAboves [ - uppBesides [uppStr "if (", pp_pred, uppStr ") {"], - uppNest 8 (pprAbsC sty then_part (c + discrim_costs + + = vcat [ + hcat [text "if (", pp_pred, text ") {"], + nest 8 (pprAbsC sty then_part (c + discrim_costs + (Cost (0, 2, 0, 0, 0)) + costs then_part)), - (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"), - uppNest 8 (pprAbsC sty else_part (c + discrim_costs + + (case nonemptyAbsC else_part of Nothing -> empty; Just _ -> text "} else {"), + nest 8 (pprAbsC sty else_part (c + discrim_costs + (Cost (0, 1, 0, 0, 0)) + costs else_part)), - uppChar '}' ] + char '}' ] {- Total costs = inherited costs (before if) + costs for accessing discrim + costs for cond branch ( = (0, 1, 0, 0, 0) ) + costs for that alternative @@ -617,27 +613,27 @@ Amendment to the above: if we can GC, we have to: \begin{code} pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs = if (may_gc && liveness_mask /= noLiveRegsMask) - then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (uppShow 80 (uppCat pp_non_void_args)) ++ "\n") + then panic ("Live register in _casm_GC_ \"" ++ casm_str ++ "\" " ++ (show (hsep pp_non_void_args)) ++ "\n") else - uppAboves [ - uppChar '{', + vcat [ + char '{', declare_local_vars, -- local var for *result* - uppAboves local_arg_decls, - -- if is_asm then uppNil else declareExtern, + vcat local_arg_decls, + -- if is_asm then empty else declareExtern, pp_save_context, process_casm local_vars pp_non_void_args casm_str, pp_restore_context, assign_results, - uppChar '}' + char '}' ] where (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs (pp_save_context, pp_restore_context) = if may_gc - then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", - uppStr "inCCallGC--; RestoreAllStgRegs();") - else ( pp_basic_saves `uppAbove` pp_saves, - pp_basic_restores `uppAbove` pp_restores) + then ( text "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", + text "inCCallGC--; RestoreAllStgRegs();") + else ( pp_basic_saves $$ pp_saves, + pp_basic_restores $$ pp_restores) non_void_args = let nvas = tail args @@ -663,17 +659,17 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo -- Remainder only used for ccall - ccall_str = uppShow 80 - (uppBesides [ + ccall_str = show + (hcat [ if null non_void_results - then uppNil - else uppStr "%r = ", - uppLparen, uppPStr op_str, uppLparen, - uppIntersperse uppComma ccall_args, - uppStr "));" + then empty + else text "%r = ", + lparen, ptext op_str, lparen, + hcat (punctuate comma ccall_args), + text "));" ]) num_args = length non_void_args - ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ] + ccall_args = take num_args [ (<>) (char '%') (int i) | i <- [0..] ] \end{code} If the argument is a heap object, we need to reach inside and pull out @@ -681,7 +677,7 @@ the bit the C world wants to see. The only heap objects which can be passed are @Array@s, @ByteArray@s and @ForeignObj@s. \begin{code} -ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty) +ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Doc, Doc) -- (a) decl and assignment, (b) local var to be used later ppr_casm_arg sty amode a_num @@ -690,7 +686,7 @@ ppr_casm_arg sty amode a_num pp_amode = pprAmode sty amode pp_kind = pprPrimKind sty a_kind - local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num) + local_var = (<>) (ptext SLIT("_ccall_arg")) (int a_num) (arg_type, pp_amode2) = case a_kind of @@ -698,18 +694,18 @@ ppr_casm_arg sty amode a_num -- for array arguments, pass a pointer to the body of the array -- (PTRS_ARR_CTS skips over all the header nonsense) ArrayRep -> (pp_kind, - uppBesides [uppPStr SLIT("PTRS_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) + hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen]) ByteArrayRep -> (pp_kind, - uppBesides [uppPStr SLIT("BYTE_ARR_CTS"),uppChar '(', pp_amode, uppRparen]) + hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen]) -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents. - ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), - uppBesides [uppPStr SLIT("ForeignObj_CLOSURE_DATA"),uppChar '(', - pp_amode, uppChar ')']) + ForeignObjRep -> (ptext SLIT("StgForeignObj"), + hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),char '(', + pp_amode, char ')']) other -> (pp_kind, pp_amode) declare_local_var - = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ] + = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ] in (declare_local_var, local_var) \end{code} @@ -729,21 +725,21 @@ For l-values, the critical questions are: ppr_casm_results :: PprStyle -- style -> [CAddrMode] -- list of results (length <= 1) - -> Unpretty -- liveness mask + -> Doc -- liveness mask -> - ( Unpretty, -- declaration of any local vars - [Unpretty], -- list of result vars (same length as results) - Unpretty ) -- assignment (if any) of results in local var to registers + ( Doc, -- declaration of any local vars + [Doc], -- list of result vars (same length as results) + Doc ) -- assignment (if any) of results in local var to registers ppr_casm_results sty [] liveness - = (uppNil, [], uppNil) -- no results + = (empty, [], empty) -- no results ppr_casm_results sty [r] liveness = let result_reg = ppr_amode sty r r_kind = getAmodeRep r - local_var = uppPStr SLIT("_ccall_result") + local_var = ptext SLIT("_ccall_result") (result_type, assign_result) = case r_kind of @@ -756,18 +752,18 @@ ppr_casm_results sty [r] liveness with makeForeignObj#. ForeignObjRep -> - (uppPStr SLIT("StgForeignObj"), - uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(', - liveness, uppComma, - result_reg, uppComma, + (ptext SLIT("StgForeignObj"), + hcat [ ptext SLIT("constructForeignObj"),char '(', + liveness, comma, + result_reg, comma, local_var, pp_paren_semi ]) -} _ -> (pprPrimKind sty r_kind, - uppBesides [ result_reg, uppEquals, local_var, uppSemi ]) + hcat [ result_reg, equals, local_var, semi ]) - declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ] + declare_local_var = hcat [ result_type, space, local_var, semi ] in (declare_local_var, [local_var], assign_result) @@ -784,15 +780,15 @@ ToDo: Any chance of giving line numbers when process-casm fails? \begin{code} process_casm :: - [Unpretty] -- results (length <= 1) - -> [Unpretty] -- arguments + [Doc] -- results (length <= 1) + -> [Doc] -- arguments -> String -- format string (with embedded %'s) -> - Unpretty -- code being generated + Doc -- code being generated process_casm results args string = process results args string where - process [] _ "" = uppNil + process [] _ "" = empty process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n") process ress args ('%':cs) @@ -801,12 +797,12 @@ process_casm results args string = process results args string error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n") ('%':css) -> - uppBeside (uppChar '%') (process ress args css) + (<>) (char '%') (process ress args css) ('r':css) -> case ress of [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n") - [r] -> uppBeside r (process [] args css) + [r] -> (<>) r (process [] args css) _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n") other -> @@ -817,13 +813,13 @@ process_casm results args string = process results args string case (read_int other) of [(num,css)] -> if 0 <= num && num < length args - then uppBeside (uppParens (args !! num)) + then (<>) (parens (args !! num)) (process ress args css) else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") _ -> error ("process_casm: not % while processing _casm_ \"" ++ string ++ "\".\n") process ress args (other_c:cs) - = uppBeside (uppChar other_c) (process ress args cs) + = (<>) (char other_c) (process ress args cs) \end{code} %************************************************************************ @@ -840,19 +836,19 @@ of the source addressing mode.) If the kind of the assignment is of @VoidRep@, then don't generate any code at all. \begin{code} -pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty +pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Doc -pprAssign sty VoidRep dest src = uppNil +pprAssign sty VoidRep dest src = empty \end{code} Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} pprAssign sty FloatRep dest@(CVal reg_rel _) src - = uppBesides [ uppPStr SLIT("ASSIGN_FLT"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ] pprAssign sty DoubleRep dest@(CVal reg_rel _) src - = uppBesides [ uppPStr SLIT("ASSIGN_DBL"),uppChar '(', ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode sty (CAddr reg_rel), comma, pprAmode sty src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -868,33 +864,33 @@ of fixed type. \begin{code} pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) - = uppBesides [ pprVanillaReg dest, uppEquals, - pprVanillaReg src, uppSemi ] + = hcat [ pprVanillaReg dest, equals, + pprVanillaReg src, semi ] pprAssign sty kind dest src | mixedTypeLocn dest -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(W_)(", -- Here is the cast + = hcat [ ppr_amode sty dest, equals, + text "(W_)(", -- Here is the cast ppr_amode sty src, pp_paren_semi ] pprAssign sty kind dest src | mixedPtrLocn dest && getAmodeRep src /= PtrRep -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(P_)(", -- Here is the cast + = hcat [ ppr_amode sty dest, equals, + text "(P_)(", -- Here is the cast ppr_amode sty src, pp_paren_semi ] pprAssign sty ByteArrayRep dest src | mixedPtrLocn src -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed - = uppBesides [ ppr_amode sty dest, uppEquals, - uppStr "(B_)(", -- Here is the cast + = hcat [ ppr_amode sty dest, equals, + text "(B_)(", -- Here is the cast ppr_amode sty src, pp_paren_semi ] pprAssign sty kind other_dest src - = uppBesides [ ppr_amode sty other_dest, uppEquals, - pprAmode sty src, uppSemi ] + = hcat [ ppr_amode sty other_dest, equals, + pprAmode sty src, semi ] \end{code} @@ -909,7 +905,7 @@ pprAssign sty kind other_dest src @pprAmode@. \begin{code} -pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty +pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Doc \end{code} For reasons discussed above under assignments, @CVal@ modes need @@ -921,9 +917,9 @@ question.) \begin{code} pprAmode sty (CVal reg_rel FloatRep) - = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ] + = hcat [ text "PK_FLT(", ppr_amode sty (CAddr reg_rel), rparen ] pprAmode sty (CVal reg_rel DoubleRep) - = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ] + = hcat [ text "PK_DBL(", ppr_amode sty (CAddr reg_rel), rparen ] \end{code} Next comes the case where there is some other cast need, and the @@ -932,7 +928,7 @@ no-cast case: \begin{code} pprAmode sty amode | mixedTypeLocn amode - = uppParens (uppBesides [ pprPrimKind sty (getAmodeRep amode), uppPStr SLIT(")("), + = parens (hcat [ pprPrimKind sty (getAmodeRep amode), ptext SLIT(")("), ppr_amode sty amode ]) | otherwise -- No cast needed = ppr_amode sty amode @@ -943,56 +939,56 @@ Now the rest of the cases for ``workhorse'' @ppr_amode@: \begin{code} ppr_amode sty (CVal reg_rel _) = case (pprRegRelative sty False{-no sign wanted-} reg_rel) of - (pp_reg, Nothing) -> uppBeside (uppChar '*') pp_reg - (pp_reg, Just offset) -> uppBesides [ pp_reg, uppBracket offset ] + (pp_reg, Nothing) -> (<>) (char '*') pp_reg + (pp_reg, Just offset) -> hcat [ pp_reg, brackets offset ] ppr_amode sty (CAddr reg_rel) = case (pprRegRelative sty True{-sign wanted-} reg_rel) of (pp_reg, Nothing) -> pp_reg - (pp_reg, Just offset) -> uppBeside pp_reg offset + (pp_reg, Just offset) -> (<>) pp_reg offset ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id -ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq) +ppr_amode sty (CTemp uniq kind) = pprUnique uniq ppr_amode sty (CLbl label kind) = pprCLabel sty label ppr_amode sty (CUnVecLbl direct vectored) - = uppBesides [uppChar '(',uppPStr SLIT("StgRetAddr"),uppChar ')', uppPStr SLIT("UNVEC"),uppChar '(', pprCLabel sty direct, uppComma, - pprCLabel sty vectored, uppRparen] + = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel sty direct, comma, + pprCLabel sty vectored, rparen] -ppr_amode sty (CCharLike char) - = uppBesides [uppPStr SLIT("CHARLIKE_CLOSURE"),uppChar '(', pprAmode sty char, uppRparen ] +ppr_amode sty (CCharLike ch) + = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode sty ch, rparen ] ppr_amode sty (CIntLike int) - = uppBesides [uppPStr SLIT("INTLIKE_CLOSURE"),uppChar '(', pprAmode sty int, uppRparen ] + = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode sty int, rparen ] -ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"'] +ppr_amode sty (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"'] -- ToDo: are these *used* for anything? ppr_amode sty (CLit lit) = pprBasicLit sty lit -ppr_amode sty (CLitLit str _) = uppPStr str +ppr_amode sty (CLitLit str _) = ptext str ppr_amode sty (COffset off) = pprHeapOffset sty off ppr_amode sty (CCode abs_C) - = uppAboves [ uppPStr SLIT("{ -- CCode"), uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ] ppr_amode sty (CLabelledCode label abs_C) - = uppAboves [ uppBesides [pprCLabel sty label, uppPStr SLIT(" = { -- CLabelledCode")], - uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + = vcat [ hcat [pprCLabel sty label, ptext SLIT(" = { -- CLabelledCode")], + nest 8 (pprAbsC sty abs_C (costs abs_C)), char '}' ] ppr_amode sty (CJoinPoint _ _) = panic "ppr_amode: CJoinPoint" ppr_amode sty (CTableEntry base index kind) - = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(", - ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, - uppPStr SLIT(")]")] + = hcat [text "((", pprPrimKind sty kind, text " *)(", + ppr_amode sty base, text "))[(I_)(", ppr_amode sty index, + ptext SLIT(")]")] ppr_amode sty (CMacroExpr pk macro as) - = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, - uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"] + = hcat [lparen, pprPrimKind sty pk, text ")(", text (show macro), lparen, + hcat (punctuate comma (map (pprAmode sty) as)), text "))"] ppr_amode sty (CCostCentre cc print_as_string) = uppCostCentre sty print_as_string cc @@ -1004,25 +1000,25 @@ ppr_amode sty (CCostCentre cc print_as_string) %* * %************************************************************************ -@pprRegRelative@ returns a pair of the @Unpretty@ for the register -(some casting may be required), and a @Maybe Unpretty@ for the offset +@pprRegRelative@ returns a pair of the @Doc@ for the register +(some casting may be required), and a @Maybe Doc@ for the offset (zero offset gives a @Nothing@). \begin{code} -addPlusSign :: Bool -> Unpretty -> Unpretty +addPlusSign :: Bool -> Doc -> Doc addPlusSign False p = p -addPlusSign True p = uppBeside (uppChar '+') p +addPlusSign True p = (<>) (char '+') p -pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0 +pprSignedInt :: Bool -> Int -> Maybe Doc -- Nothing => 0 pprSignedInt sign_wanted n = if n == 0 then Nothing else - if n > 0 then Just (addPlusSign sign_wanted (uppInt n)) - else Just (uppInt n) + if n > 0 then Just (addPlusSign sign_wanted (int n)) + else Just (int n) pprRegRelative :: PprStyle -> Bool -- True <=> Print leading plus sign (if +ve) -> RegRelative - -> (Unpretty, Maybe Unpretty) + -> (Doc, Maybe Doc) pprRegRelative sty sign_wanted (SpARel spA off) = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt spA off)) @@ -1037,7 +1033,7 @@ pprRegRelative sty sign_wanted r@(HpRel hp off) if isZeroOff to_print then (pp_Hp, Nothing) else - (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print))) + (pp_Hp, Just ((<>) (char '-') (pprHeapOffset sty to_print))) -- No parens needed because pprHeapOffset -- does them when necessary @@ -1056,53 +1052,53 @@ represented by a discriminated union (@StgUnion@), so we use the @PrimRep@ to select the union tag. \begin{code} -pprMagicId :: PprStyle -> MagicId -> Unpretty +pprMagicId :: PprStyle -> MagicId -> Doc -pprMagicId sty BaseReg = uppPStr SLIT("BaseReg") -pprMagicId sty StkOReg = uppPStr SLIT("StkOReg") +pprMagicId sty BaseReg = ptext SLIT("BaseReg") +pprMagicId sty StkOReg = ptext SLIT("StkOReg") pprMagicId sty (VanillaReg pk n) - = uppBesides [ pprVanillaReg n, uppChar '.', + = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n)) -pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n)) -pprMagicId sty TagReg = uppPStr SLIT("TagReg") -pprMagicId sty RetReg = uppPStr SLIT("RetReg") -pprMagicId sty SpA = uppPStr SLIT("SpA") -pprMagicId sty SuA = uppPStr SLIT("SuA") -pprMagicId sty SpB = uppPStr SLIT("SpB") -pprMagicId sty SuB = uppPStr SLIT("SuB") -pprMagicId sty Hp = uppPStr SLIT("Hp") -pprMagicId sty HpLim = uppPStr SLIT("HpLim") -pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg") -pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg") -pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg") -pprMagicId sty CurCostCentre = uppPStr SLIT("CCC") +pprMagicId sty (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n)) +pprMagicId sty (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n)) +pprMagicId sty TagReg = ptext SLIT("TagReg") +pprMagicId sty RetReg = ptext SLIT("RetReg") +pprMagicId sty SpA = ptext SLIT("SpA") +pprMagicId sty SuA = ptext SLIT("SuA") +pprMagicId sty SpB = ptext SLIT("SpB") +pprMagicId sty SuB = ptext SLIT("SuB") +pprMagicId sty Hp = ptext SLIT("Hp") +pprMagicId sty HpLim = ptext SLIT("HpLim") +pprMagicId sty LivenessReg = ptext SLIT("LivenessReg") +pprMagicId sty StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg") +pprMagicId sty StkStubReg = ptext SLIT("StkStubReg") +pprMagicId sty CurCostCentre = ptext SLIT("CCC") pprMagicId sty VoidReg = panic "pprMagicId:VoidReg!" -pprVanillaReg :: FAST_INT -> Unpretty +pprVanillaReg :: FAST_INT -> Doc -pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n)) +pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) -pprUnionTag :: PrimRep -> Unpretty +pprUnionTag :: PrimRep -> Doc -pprUnionTag PtrRep = uppChar 'p' -pprUnionTag CodePtrRep = uppPStr SLIT("fp") -pprUnionTag DataPtrRep = uppChar 'd' -pprUnionTag RetRep = uppChar 'r' +pprUnionTag PtrRep = char 'p' +pprUnionTag CodePtrRep = ptext SLIT("fp") +pprUnionTag DataPtrRep = char 'd' +pprUnionTag RetRep = char 'r' pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?" -pprUnionTag CharRep = uppChar 'c' -pprUnionTag IntRep = uppChar 'i' -pprUnionTag WordRep = uppChar 'w' -pprUnionTag AddrRep = uppChar 'v' -pprUnionTag FloatRep = uppChar 'f' +pprUnionTag CharRep = char 'c' +pprUnionTag IntRep = char 'i' +pprUnionTag WordRep = char 'w' +pprUnionTag AddrRep = char 'v' +pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" -pprUnionTag StablePtrRep = uppChar 'i' -pprUnionTag ForeignObjRep = uppChar 'p' +pprUnionTag StablePtrRep = char 'i' +pprUnionTag ForeignObjRep = char 'p' -pprUnionTag ArrayRep = uppChar 'p' -pprUnionTag ByteArrayRep = uppChar 'b' +pprUnionTag ArrayRep = char 'p' +pprUnionTag ByteArrayRep = char 'b' pprUnionTag _ = panic "pprUnionTag:Odd kind" \end{code} @@ -1111,34 +1107,34 @@ pprUnionTag _ = panic "pprUnionTag:Odd kind" Find and print local and external declarations for a list of Abstract~C statements. \begin{code} -pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-}) -pprTempAndExternDecls AbsCNop = (uppNil, uppNil) +pprTempAndExternDecls :: AbstractC -> (Doc{-temps-}, Doc{-externs-}) +pprTempAndExternDecls AbsCNop = (empty, empty) pprTempAndExternDecls (AbsCStmts stmt1 stmt2) = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) -> ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) -> case (catMaybes [t_p1, t_p2]) of { real_temps -> case (catMaybes [e_p1, e_p2]) of { real_exts -> - returnTE (uppAboves real_temps, uppAboves real_exts) }} + returnTE (vcat real_temps, vcat real_exts) }} ) pprTempAndExternDecls other_stmt = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) -> returnTE ( case maybe_t of - Nothing -> uppNil + Nothing -> empty Just pp -> pp, case maybe_e of - Nothing -> uppNil + Nothing -> empty Just pp -> pp ) ) -pprBasicLit :: PprStyle -> Literal -> Unpretty -pprPrimKind :: PprStyle -> PrimRep -> Unpretty +pprBasicLit :: PprStyle -> Literal -> Doc +pprPrimKind :: PprStyle -> PrimRep -> Doc -pprBasicLit sty lit = uppStr (showLiteral sty lit) -pprPrimKind sty k = uppStr (showPrimRep k) +pprBasicLit sty lit = text (showLiteral sty lit) +pprPrimKind sty k = text (showPrimRep k) \end{code} @@ -1211,15 +1207,15 @@ labelSeenTE label env@(seen_uniqs, seen_labels) \end{code} \begin{code} -pprTempDecl :: Unique -> PrimRep -> Unpretty +pprTempDecl :: Unique -> PrimRep -> Doc pprTempDecl uniq kind - = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ] + = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ] -pprExternDecl :: CLabel -> PrimRep -> Unpretty +pprExternDecl :: CLabel -> PrimRep -> Doc pprExternDecl clabel kind = if not (needsCDecl clabel) then - uppNil -- do not print anything for "known external" things (e.g., < PreludeCore) + empty -- do not print anything for "known external" things (e.g., < PreludeCore) else case ( case kind of @@ -1227,19 +1223,19 @@ pprExternDecl clabel kind _ -> ppLocalnessMacro False{-data-} clabel ) of { pp_macro_str -> - uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ] + hcat [ pp_macro_str, lparen, pprCLabel PprForC clabel, pp_paren_semi ] } \end{code} \begin{code} -ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-}) +ppr_decls_AbsC :: AbstractC -> TeM (Maybe Doc{-temps-}, Maybe Doc{-externs-}) ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing) ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2) = ppr_decls_AbsC stmts_1 `thenTE` \ p1 -> ppr_decls_AbsC stmts_2 `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) + returnTE (maybe_vcat [p1, p2]) ppr_decls_AbsC (CClosureUpdInfo info) = ppr_decls_AbsC info @@ -1249,7 +1245,7 @@ ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing) ppr_decls_AbsC (CAssign dest source) = ppr_decls_Amode dest `thenTE` \ p1 -> ppr_decls_Amode source `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) + returnTE (maybe_vcat [p1, p2]) ppr_decls_AbsC (CJump target) = ppr_decls_Amode target @@ -1261,7 +1257,7 @@ ppr_decls_AbsC (CSwitch discrim alts deflt) = ppr_decls_Amode discrim `thenTE` \ pdisc -> mapTE ppr_alt_stuff alts `thenTE` \ palts -> ppr_decls_AbsC deflt `thenTE` \ pdeflt -> - returnTE (maybe_uppAboves (pdisc:pdeflt:palts)) + returnTE (maybe_vcat (pdisc:pdeflt:palts)) where ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC @@ -1300,7 +1296,7 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _) (case maybe_fast of Nothing -> returnTE (Nothing, Nothing) Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 -> - returnTE (maybe_uppAboves [p1, p2, p3]) + returnTE (maybe_vcat [p1, p2, p3]) where entry_lbl = CLbl slow_lbl CodePtrRep slow_lbl = case (nonemptyAbsC slow) of @@ -1310,14 +1306,14 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _) ppr_decls_AbsC (CRetVector label maybe_amodes absC) = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 -> ppr_decls_AbsC absC `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) + returnTE (maybe_vcat [p1, p2]) ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes \end{code} \begin{code} -ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty) +ppr_decls_Amode :: CAddrMode -> TeM (Maybe Doc, Maybe Doc) ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing) @@ -1355,13 +1351,13 @@ ppr_decls_Amode (CUnVecLbl direct vectored) = labelSeenTE direct `thenTE` \ dlbl_seen -> labelSeenTE vectored `thenTE` \ vlbl_seen -> let - ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrRep - vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrRep + ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep + vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep in returnTE (Nothing, if (dlbl_seen || not (needsCDecl direct)) && (vlbl_seen || not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) + else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen])) -} ppr_decls_Amode (CUnVecLbl direct vectored) @@ -1371,18 +1367,18 @@ ppr_decls_Amode (CUnVecLbl direct vectored) --labelSeenTE direct `thenTE` \ dlbl_seen -> --labelSeenTE vectored `thenTE` \ vlbl_seen -> let - ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrRep - vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrRep + ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep + vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep in returnTE (Nothing, if ({-dlbl_seen ||-} not (needsCDecl direct)) && ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing - else Just (uppBesides [uppPStr SLIT("UNVEC"),uppChar '(', ddcl, uppComma, vdcl, uppRparen])) + else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen])) ppr_decls_Amode (CTableEntry base index _) = ppr_decls_Amode base `thenTE` \ p1 -> ppr_decls_Amode index `thenTE` \ p2 -> - returnTE (maybe_uppAboves [p1, p2]) + returnTE (maybe_vcat [p1, p2]) ppr_decls_Amode (CMacroExpr _ _ amodes) = ppr_decls_Amodes amodes @@ -1390,19 +1386,19 @@ ppr_decls_Amode (CMacroExpr _ _ amodes) ppr_decls_Amode other = returnTE (Nothing, Nothing) -maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty) -maybe_uppAboves ps +maybe_vcat :: [(Maybe Doc, Maybe Doc)] -> (Maybe Doc, Maybe Doc) +maybe_vcat ps = case (unzip ps) of { (ts, es) -> case (catMaybes ts) of { real_ts -> case (catMaybes es) of { real_es -> - (if (null real_ts) then Nothing else Just (uppAboves real_ts), - if (null real_es) then Nothing else Just (uppAboves real_es)) + (if (null real_ts) then Nothing else Just (vcat real_ts), + if (null real_es) then Nothing else Just (vcat real_es)) } } } \end{code} \begin{code} -ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty) +ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Doc, Maybe Doc) ppr_decls_Amodes amodes = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> - returnTE ( maybe_uppAboves ps ) + returnTE ( maybe_vcat ps ) \end{code} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 738ea2f..22b699d 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -10,7 +10,7 @@ module Demand where import PprStyle ( PprStyle ) import Outputable -import Pretty ( SYN_IE(Pretty), PrettyRep, ppStr ) +import Pretty ( Doc, text ) import Util ( panic ) \end{code} @@ -124,7 +124,7 @@ instance Show Demand where ch = if wu then "U" else "u" instance Outputable Demand where - ppr sty si = ppStr (showList [si] "") + ppr sty si = text (showList [si] "") \end{code} diff --git a/ghc/compiler/basicTypes/FieldLabel.hi-boot b/ghc/compiler/basicTypes/FieldLabel.hi-boot new file mode 100644 index 0000000..bfae521 --- /dev/null +++ b/ghc/compiler/basicTypes/FieldLabel.hi-boot @@ -0,0 +1,5 @@ +_interface_ FieldLabel 1 +_exports_ +FieldLabel FieldLabel; +_declarations_ +1 data FieldLabel; diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index ea2ee94..0173833 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -10,13 +10,16 @@ module FieldLabel where IMP_Ubiq(){-uitous-} -import Name ( Name{-instance Eq/Outputable-}, nameUnique ) +import Name --( Name{-instance Eq/Outputable-}, nameUnique ) import Type ( SYN_IE(Type) ) + +import Outputable +import UniqFM ( SYN_IE(Uniquable) ) \end{code} \begin{code} data FieldLabel - = FieldLabel Name + = FieldLabel Name -- Also used as the Name of the field selector Id Type FieldLabelTag diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot index 69169c0..8c1d44f 100644 --- a/ghc/compiler/basicTypes/Id.hi-boot +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -1,8 +1,17 @@ _interface_ Id 1 _exports_ - +Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon nmbrId; +_instances_ +instance {Outputable.Outputable Id} = $d1; _declarations_ - +1 $d1 _:_ {Outputable.Outputable Id} ;; 1 type Id = Id.GenId Type.Type ; 1 data GenId ty ; +1 data StrictnessMark = MarkedStrict | NotMarkedStrict ; +1 dataConArgTys _:_ Id -> [Type.Type] -> [Type.Type] ;; +1 idType _:_ Id -> Type.Type ;; +1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;; +1 mkDataCon _:_ Name.Name -> [StrictnessMark] -> [FieldLabel.FieldLabel] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [Type.Type] -> TyCon.TyCon -> Id ;; +1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type.Type -> Id ;; +1 nmbrId _:_ Id -> PprEnv.NmbrEnv -> (PprEnv.NmbrEnv, Id) ;; diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 8419e0d..786d69a 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -19,7 +19,7 @@ module Id ( mkDataCon, mkDefaultMethodId, mkDictFunId, - mkIdWithNewUniq, + mkIdWithNewUniq, mkIdWithNewName, mkImported, mkInstId, mkMethodSelId, @@ -41,7 +41,6 @@ module Id ( dataConRepType, dataConArgTys, - dataConArity, dataConNumFields, dataConFieldLabels, dataConRawArgTys, @@ -59,8 +58,8 @@ module Id ( cmpId_withSpecDataCon, externallyVisibleId, idHasNoFreeTyVars, - idWantsToBeINLINEd, - idMustBeINLINEd, + idWantsToBeINLINEd, getInlinePragma, + idMustBeINLINEd, idMustNotBeINLINEd, isBottomingId, isConstMethodId, isConstMethodId_maybe, @@ -111,7 +110,7 @@ module Id ( getIdUpdateInfo, getPragmaInfo, replaceIdInfo, - addInlinePragma, + addInlinePragma, nukeNoInlinePragma, addNoInlinePragma, -- IdEnvs AND IdSets SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet), @@ -145,25 +144,30 @@ module Id ( ) where IMP_Ubiq() + IMPORT_DELOOPER(IdLoop) -- for paranoia checking IMPORT_DELOOPER(TyLoop) -- for paranoia checking + import Bag import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) import IdInfo import Maybes ( maybeToBool ) -import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, +import Name {- ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, mkCompoundName, mkInstDeclName, isLocallyDefinedName, occNameString, modAndOcc, isLocallyDefined, changeUnique, isWiredInName, nameString, getOccString, setNameVisibility, isExported, ExportFlag(..), DefnInfo, Provenance, OccName(..), Name - ) + ) -} import PrelMods ( pREL_TUP, pREL_BASE ) import Lex ( mkTupNameStr ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) +#if __GLASGOW_HASKELL__ >= 202 +import PrimOp ( PrimOp ) +#endif import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) ) import PprType ( getTypeString, specMaybeTysSuffix, nmbrType, nmbrTyVar, @@ -172,15 +176,15 @@ import PprType ( getTypeString, specMaybeTysSuffix, import PprStyle import Pretty import MatchEnv ( MatchEnv ) -import SrcLoc ( mkBuiltinSrcLoc ) +import SrcLoc --( mkBuiltinSrcLoc ) import TysWiredIn ( tupleTyCon ) -import TyCon ( TyCon, tyConDataCons ) -import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, +import TyCon --( TyCon, tyConDataCons ) +import Type {- ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, applyTyCon, instantiateTy, mkForAllTys, tyVarsOfType, applyTypeEnvToTy, typePrimRep, GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) - ) -import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) + ) -} +import TyVar --( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) import Usage ( SYN_IE(UVar) ) import UniqFM import UniqSet -- practically all of it @@ -188,9 +192,10 @@ import Unique ( getBuiltinUniques, pprUnique, showUnique, incrUnique, Unique{-instance Ord3-} ) -import Util ( mapAccumL, nOfThem, zipEqual, assoc, +import Outputable ( ifPprDebug, Outputable(..) ) +import Util {- ( mapAccumL, nOfThem, zipEqual, assoc, panic, panic#, pprPanic, assertPanic - ) + ) -} \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that @@ -241,11 +246,15 @@ data IdDetails | DataConId ConTag [StrictnessMark] -- Strict args; length = arity - [FieldLabel] -- Field labels for this constructor + [FieldLabel] -- Field labels for this constructor; + --length = 0 (not a record) or arity - [TyVar] [(Class,Type)] [Type] TyCon + [TyVar] [(Class,Type)] -- Type vars and context for the data type decl + [TyVar] [(Class,Type)] -- Ditto for the context of the constructor, + -- the existentially quantified stuff + [Type] TyCon -- Args and result tycon -- the type is: - -- forall tyvars . theta_ty => + -- forall tyvars1 ++ tyvars2. theta1 ++ theta2 => -- unitype_1 -> ... -> unitype_n -> tycon tyvars | TupleConId Int -- Its arity @@ -477,10 +486,10 @@ properties, but they may not. %************************************************************************ \begin{code} -isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True -isDataCon (Id _ _ _ (TupleConId _) _ _) = True -isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec -isDataCon other = False +isDataCon (Id _ _ _ (DataConId _ __ _ _ _ _ _ _) _ _) = True +isDataCon (Id _ _ _ (TupleConId _) _ _) = True +isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec +isDataCon other = False isTupleCon (Id _ _ _ (TupleConId _) _ _) = True isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec @@ -513,7 +522,7 @@ idHasNoFreeTyVars :: Id -> Bool toplevelishId (Id _ _ _ details _ _) = chk details where - chk (DataConId _ _ _ _ _ _ _) = True + chk (DataConId _ __ _ _ _ _ _ _) = True chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True @@ -534,7 +543,7 @@ toplevelishId (Id _ _ _ details _ _) idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _) = True + chk (DataConId _ _ _ _ _ _ _ _ _) = True chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True @@ -572,7 +581,7 @@ omitIfaceSigForId (Id _ name _ details _ _) -- remember that all type and class decls appear in the interface file. -- The dfun id must *not* be omitted, because it carries version info for -- the instance decl - (DataConId _ _ _ _ _ _ _) -> True + (DataConId _ _ _ _ _ _ _ _ _) -> True (TupleConId _) -> True (RecordSelId _) -> True (SuperDictSelId _ _) -> True @@ -821,7 +830,7 @@ mkWorkerId u unwrkr ty info name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str mkInstId u ty name - = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id u name ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo {-LATER: getConstMethodId clas op ty @@ -832,12 +841,12 @@ getConstMethodId clas op ty in case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of Just xx -> xx - Nothing -> pprError "ERROR: getConstMethodId:" (ppAboves [ - ppCat [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, + Nothing -> pprError "ERROR: getConstMethodId:" (vcat [ + hsep [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, ppr PprDebug sel_id], - ppStr "(This can arise if an interface pragma refers to an instance", - ppStr "but there is no imported interface which *defines* that instance.", - ppStr "The info above, however ugly, should indicate what else you need to import." + text "(This can arise if an interface pragma refers to an instance", + text "but there is no imported interface which *defines* that instance.", + text "The info above, however ugly, should indicate what else you need to import." ]) -} @@ -861,8 +870,9 @@ mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info mkPrimitiveId n ty primop = addStandardIdInfo $ - Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo - + Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo + -- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined. + -- It's only true for primitives, because we don't want to make a closure for each of them. \end{code} \begin{code} @@ -928,6 +938,10 @@ setIdVisibility mod (Id uniq name ty details prag info) mkIdWithNewUniq :: Id -> Unique -> Id mkIdWithNewUniq (Id _ n ty details prag info) u = Id u (changeUnique n u) ty details prag info + +mkIdWithNewName :: Id -> Name -> Id +mkIdWithNewName (Id _ _ ty details prag info) new_name + = Id (uniqueOf new_name) new_name ty details prag info \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -976,21 +990,6 @@ getIdArity id@(Id _ _ _ _ _ id_info) = --ASSERT( not (isDataCon id)) arityInfo id_info -dataConArity, dataConNumFields :: DataCon -> Int - -dataConArity id@(Id _ _ _ _ _ id_info) - = ASSERT(isDataCon id) - case arityInfo id_info of - ArityExactly a -> a - other -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) - -dataConNumFields id - = ASSERT(isDataCon id) - case (dataConSig id) of { (_, _, arg_tys, _) -> - length arg_tys } - -isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience - addIdArity :: Id -> ArityInfo -> Id addIdArity (Id u n ty details pinfo info) arity = Id u n ty details pinfo (info `addArityInfo` arity) @@ -1005,11 +1004,13 @@ addIdArity (Id u n ty details pinfo info) arity \begin{code} mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType -> [TauType] -> TyCon + -> [TyVar] -> ThetaType + -> [TyVar] -> ThetaType + -> [TauType] -> TyCon -> Id -- can get the tag and all the pieces of the type from the Type -mkDataCon n stricts fields tvs ctxt args_tys tycon +mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon = ASSERT(length stricts == length args_tys) addStandardIdInfo data_con where @@ -1019,7 +1020,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon = Id (nameUnique n) n data_con_ty - (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) + (DataConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon) IWantToBeINLINEd -- Always inline constructors if possible noIdInfo @@ -1027,7 +1028,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon data_con_family = tyConDataCons tycon data_con_ty - = mkSigmaTy tvs ctxt + = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt) (mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs))) @@ -1044,24 +1045,39 @@ fIRST_TAG :: ConTag fIRST_TAG = 1 -- Tags allocated from here for real constructors \end{code} +dataConNumFields gives the number of actual fields in the +{\em representation} of the data constructor. This may be more than appear +in the source code; the extra ones are the existentially quantified +dictionaries + +\begin{code} +dataConNumFields id + = ASSERT(isDataCon id) + case (dataConSig id) of { (_, _, _, con_theta, arg_tys, _) -> + length con_theta + length arg_tys } + +isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience +\end{code} + + \begin{code} dataConTag :: DataCon -> ConTag -- will panic if not a DataCon -dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _ _ _) _ _) = tag dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a -dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) +dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) - = (tyvars, theta_ty, arg_tys, tycon) +dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) + = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) dataConSig (Id _ _ _ (TupleConId arity) _ _) - = (tyvars, [], tyvar_tys, tupleTyCon arity) + = (tyvars, [], [], [], tyvar_tys, tupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars @@ -1086,16 +1102,16 @@ dataConRepType con (tyvars, theta, tau) = splitSigmaTy (idType con) dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _ _ _) _ _) = fields dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts +dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _ _ _) _ _) = stricts dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) = nOfThem arity NotMarkedStrict dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience -dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys } +dataConRawArgTys con = case (dataConSig con) of { (_,_, _, _, arg_tys,_) -> arg_tys } dataConArgTys :: DataCon -> [Type] -- Instantiated at these types @@ -1103,8 +1119,8 @@ dataConArgTys :: DataCon dataConArgTys con_id inst_tys = map (instantiateTy tenv) arg_tys where - (tyvars, _, arg_tys, _) = dataConSig con_id - tenv = zipEqual "dataConArgTys" tyvars inst_tys + (tyvars, _, _, _, arg_tys, _) = dataConSig con_id + tenv = zipEqual "dataConArgTys" tyvars inst_tys \end{code} \begin{code} @@ -1159,26 +1175,37 @@ The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. \begin{code} +getInlinePragma :: Id -> PragmaInfo +getInlinePragma (Id _ _ _ _ prag _) = prag + idWantsToBeINLINEd :: Id -> Bool idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True idWantsToBeINLINEd _ = False +idMustNotBeINLINEd (Id _ _ _ _ IMustNotBeINLINEd _) = True +idMustNotBeINLINEd _ = False + +idMustBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True +idMustBeINLINEd _ = False + addInlinePragma :: Id -> Id addInlinePragma (Id u sn ty details _ info) = Id u sn ty details IWantToBeINLINEd info -\end{code} - -The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined. -It's only true for primitives, because we don't want to make a closure for each of them. +nukeNoInlinePragma :: Id -> Id +nukeNoInlinePragma id@(Id u sn ty details IMustNotBeINLINEd info) + = Id u sn ty details NoPragmaInfo info +nukeNoInlinePragma id@(Id u sn ty details _ info) = id -- Otherwise no-op -\begin{code} -idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True -idMustBeINLINEd other = False +addNoInlinePragma :: Id -> Id +addNoInlinePragma id@(Id u sn ty details _ info) + = Id u sn ty details IMustNotBeINLINEd info \end{code} + %************************************************************************ %* * \subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@} @@ -1316,14 +1343,22 @@ instance Outputable {-Id, i.e.:-}(GenId Type) where ppr sty id = pprId sty id showId :: PprStyle -> Id -> String -showId sty id = ppShow 80 (pprId sty id) +showId sty id = show (pprId sty id) \end{code} Default printing code (not used for interfaces): \begin{code} -pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty +pprId :: Outputable ty => PprStyle -> GenId ty -> Doc + +pprId sty (Id u n _ _ prags _) + = hcat [ppr sty n, pp_prags] + where + pp_prags = ifPprDebug sty (case prags of + IMustNotBeINLINEd -> text "{n}" + IWantToBeINLINEd -> text "{i}" + IMustBeINLINEd -> text "{I}" + other -> empty) -pprId sty (Id u n _ _ _ _) = ppr sty n -- WDP 96/05/06: We can re-elaborate this as we go along... \end{code} @@ -1475,7 +1510,8 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv = (nenv, id) -- nothing to do for tuples -nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) +nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info) + nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly idenv u) of Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx) Nothing -> @@ -1483,7 +1519,7 @@ nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2 - new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc + new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc new_id = Id u n (bottom "ty") new_det prag info in (nenv3, new_id) @@ -1493,12 +1529,14 @@ nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag ------------ nmbr_details :: IdDetails -> NmbrM IdDetails -nmbr_details (DataConId tag marks fields tvs theta arg_tys tc) +nmbr_details (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs -> + mapNmbr nmbrTyVar con_tvs `thenNmbr` \ new_con_tvs -> mapNmbr nmbrField fields `thenNmbr` \ new_fields -> mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> + mapNmbr nmbr_theta con_theta `thenNmbr` \ new_con_theta -> mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys -> - returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc) + returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_theta new_arg_tys tc) where nmbr_theta (c,t) = --nmbrClass c `thenNmbr` \ new_c -> diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 3c8270b..25bd150 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -195,11 +195,11 @@ applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold ppIdInfo :: PprStyle -> Bool -- True <=> print specialisations, please -> IdInfo - -> Pretty + -> Doc ppIdInfo sty specs_please (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype) - = ppCat [ + = hsep [ -- order is important!: ppArityInfo sty arity, ppUpdateInfo sty update, @@ -208,9 +208,9 @@ ppIdInfo sty specs_please ppStrictnessInfo sty strictness, if specs_please - then ppNil -- ToDo -- sty (not (isDataCon for_this_id)) + then empty -- ToDo -- sty (not (isDataCon for_this_id)) -- better_id_fn inline_env (mEnvToList specenv) - else ppNil, + else empty, -- DemandInfo needn't be printed since it has no effect on interfaces ppDemandInfo sty demand, @@ -238,12 +238,11 @@ unknownArity = UnknownArity arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity -addArityInfo id_info UnknownArity = id_info addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i -ppArityInfo sty UnknownArity = ppNil -ppArityInfo sty (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity] -ppArityInfo sty (ArityAtLeast arity) = ppCat [ppPStr SLIT("_A>_"), ppInt arity] +ppArityInfo sty UnknownArity = empty +ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity] +ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity] \end{code} %************************************************************************ @@ -281,9 +280,9 @@ demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i -ppDemandInfo PprInterface _ = ppNil -ppDemandInfo sty UnknownDemand = ppStr "{-# L #-}" -ppDemandInfo sty (DemandedAsPer info) = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"] +ppDemandInfo PprInterface _ = empty +ppDemandInfo sty UnknownDemand = text "{-# L #-}" +ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"] \end{code} %************************************************************************ @@ -353,14 +352,14 @@ strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict addStrictnessInfo id_info NoStrictnessInfo = id_info addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i -ppStrictnessInfo sty NoStrictnessInfo = ppNil -ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_bot_") +ppStrictnessInfo sty NoStrictnessInfo = empty +ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_") ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) - = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr] + = hsep [ptext SLIT("_S_"), text (showList wrapper_args ""), pp_wrkr] where pp_wrkr = case wrkr_maybe of - Nothing -> ppNil + Nothing -> empty Just wrkr -> ppr sty wrkr \end{code} @@ -432,9 +431,9 @@ updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update addUpdateInfo id_info NoUpdateInfo = id_info addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i -ppUpdateInfo sty NoUpdateInfo = ppNil -ppUpdateInfo sty (SomeUpdateInfo []) = ppNil -ppUpdateInfo sty (SomeUpdateInfo spec) = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec)) +ppUpdateInfo sty NoUpdateInfo = empty +ppUpdateInfo sty (SomeUpdateInfo []) = empty +ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec)) \end{code} %************************************************************************ @@ -460,8 +459,8 @@ deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest addDeforestInfo id_info Don'tDeforest = id_info addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i -ppDeforestInfo sty Don'tDeforest = ppNil -ppDeforestInfo sty DoDeforest = ppPStr SLIT("_DEFOREST_") +ppDeforestInfo sty Don'tDeforest = empty +ppDeforestInfo sty DoDeforest = ptext SLIT("_DEFOREST_") \end{code} %************************************************************************ @@ -496,16 +495,16 @@ argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au addArgUsageInfo id_info NoArgUsageInfo = id_info addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i -ppArgUsageInfo sty NoArgUsageInfo = ppNil -ppArgUsageInfo sty (SomeArgUsageInfo aut) = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut) +ppArgUsageInfo sty NoArgUsageInfo = empty +ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut) -ppArgUsage (ArgUsage n) = ppInt n -ppArgUsage (UnknownArgUsage) = ppChar '-' +ppArgUsage (ArgUsage n) = int n +ppArgUsage (UnknownArgUsage) = char '-' -ppArgUsageType aut = ppBesides - [ ppChar '"' , - ppIntersperse ppComma (map ppArgUsage aut), - ppChar '"' ] +ppArgUsageType aut = hcat + [ char '"' , + hcat (punctuate comma (map ppArgUsage aut)), + char '"' ] \end{code} %************************************************************************ @@ -539,15 +538,15 @@ fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb addFBTypeInfo id_info NoFBTypeInfo = id_info addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info -ppFBTypeInfo sty NoFBTypeInfo = ppNil +ppFBTypeInfo sty NoFBTypeInfo = empty ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod)) - = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod) + = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod) -ppFBType cons prod = ppBesides - ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ]) +ppFBType cons prod = hcat + ([ char '"' ] ++ map ppCons cons ++ [ char '-', ppProd prod, char '"' ]) where - ppCons FBGoodConsum = ppChar 'G' - ppCons FBBadConsum = ppChar 'B' - ppProd FBGoodProd = ppChar 'G' - ppProd FBBadProd = ppChar 'B' + ppCons FBGoodConsum = char 'G' + ppCons FBBadConsum = char 'B' + ppProd FBGoodProd = char 'G' + ppProd FBBadProd = char 'B' \end{code} diff --git a/ghc/compiler/basicTypes/IdLoop.hs b/ghc/compiler/basicTypes/IdLoop.hs new file mode 100644 index 0000000..8b8520c --- /dev/null +++ b/ghc/compiler/basicTypes/IdLoop.hs @@ -0,0 +1,16 @@ +module IdLoop + + ( + module CostCentre, + module SpecEnv, + module CoreUnfold, + module StdIdInfo, + module Id + ) where + +import CostCentre +import Id +import SpecEnv +import CoreUnfold +import StdIdInfo + diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index eb21149..4d2fdf5 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -9,7 +9,7 @@ import PreludeStdIO ( Maybe ) import BinderInfo ( BinderInfo ) import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg ) -import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), mkUnfolding, SimpleUnfolding(..), FormSummary(..), noUnfolding ) import CoreUtils ( unTagBinders ) import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, @@ -24,7 +24,7 @@ import CostCentre ( CostCentre, preludeDictsCostCentre, mkAllCafsCC, mkAllDictsCC, mkUserCC ) -import IdInfo ( IdInfo ) +import IdInfo ( IdInfo, DemandInfo ) import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv ) import Literal ( Literal ) import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) @@ -33,7 +33,8 @@ import Outputable ( Outputable(..) ) import PprEnv ( NmbrEnv ) import PprStyle ( PprStyle ) import PprType ( pprParendGenType ) -import Pretty ( PrettyRep ) +import PragmaInfo ( PragmaInfo ) +import Pretty ( Doc ) import Type ( GenType ) import TyVar ( GenTyVar ) import UniqFM ( UniqFM ) @@ -54,16 +55,10 @@ isNullSpecEnv :: SpecEnv -> Bool externallyVisibleId :: Id -> Bool isDataCon :: GenId ty -> Bool isWorkerId :: GenId ty -> Bool -isWrapperId :: Id -> Bool -unfoldingUnfriendlyId :: Id -> Bool -getIdInfo :: Id -> IdInfo -nullIdEnv :: UniqFM a -lookupIdEnv :: UniqFM b -> GenId a -> Maybe b -mAX_WORKER_ARGS :: Int nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id) -pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun + type IdEnv a = UniqFM a type CoreExpr = GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) @@ -78,6 +73,7 @@ instance Outputable (GenTyVar a) instance (Outputable a) => Outputable (GenId a) instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b) +data DemandInfo data SpecEnv data NmbrEnv data MagicUnfoldingFun @@ -90,6 +86,7 @@ data FormSummary = VarForm | ValueForm | BottomForm | OtherForm data Unfolding noUnfolding :: Unfolding +mkUnfolding :: PragmaInfo -> CoreExpr -> Unfolding -- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index a9ae815..3eb9021 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -17,9 +17,9 @@ import CoreUnfold ( UnfoldingGuidance(..), Unfolding, mkUnfolding ) import Id ( mkPrimitiveId, mkTemplateLocals ) import IdInfo -- quite a few things import StdIdInfo -import Name ( mkWiredInIdName ) +import Name ( mkWiredInIdName, Name ) import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str, - PrimOpInfo(..), PrimOpResultInfo(..) ) + PrimOpInfo(..), PrimOpResultInfo(..), PrimOp ) import PrelMods ( gHC__ ) import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon ) import TysWiredIn ( boolTy ) diff --git a/ghc/compiler/basicTypes/Literal.hi-boot b/ghc/compiler/basicTypes/Literal.hi-boot new file mode 100644 index 0000000..833a8e8 --- /dev/null +++ b/ghc/compiler/basicTypes/Literal.hi-boot @@ -0,0 +1,5 @@ +_interface_ Literal 1 +_exports_ +Literal Literal; +_declarations_ +1 data Literal; diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index b561cc3..cf9909e 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -29,7 +29,11 @@ import CStrings ( stringToC, charToC, charToEasyHaskell ) import TysWiredIn ( stringTy ) import Pretty -- pretty-printing stuff import PprStyle ( PprStyle(..), codeStyle, ifaceStyle ) -import Util ( thenCmp, panic, pprPanic ) +import Util --( thenCmp, panic, pprPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Type +import Outputable +#endif \end{code} So-called @Literals@ are {\em either}: @@ -167,9 +171,9 @@ literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString" The boring old output stuff: \begin{code} -ppCast :: PprStyle -> FAST_STRING -> Pretty -ppCast PprForC cast = ppPStr cast -ppCast _ _ = ppNil +ppCast :: PprStyle -> FAST_STRING -> Doc +ppCast PprForC cast = ptext cast +ppCast _ _ = empty -- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") -- exceptions: MachFloat and MachAddr get an initial keyword prefix @@ -186,22 +190,22 @@ instance Outputable Literal where PprInterface -> charToEasyHaskell ch _ -> [ch] in - ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''] + hcat [ppCast sty SLIT("(C_)"), char '\'', text char_encoding, char '\''] ppr sty (MachStr s) - | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] - | otherwise = ppBesides [ppChar '"', ppPStr s, ppChar '"'] + | codeStyle sty = hcat [char '"', text (stringToC (_UNPK_ s)), char '"'] + | otherwise = text (show (_UNPK_ s)) ppr sty lit@(NoRepStr s) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppBesides [ppPStr SLIT("_string_"), ppChar '"', ppPStr s,ppChar '"'] + | otherwise = hcat [ptext SLIT("_string_ "), text (show (_UNPK_ s))] ppr sty (MachInt i signed) | codeStyle sty && out_of_range = panic ("ERROR: Int " ++ show i ++ " out of range [" ++ show range_min ++ " .. " ++ show range_max ++ "]\n") - | otherwise = ppInteger i + | otherwise = integer i where range_min = if signed then minInt else 0 @@ -209,28 +213,28 @@ instance Outputable Literal where out_of_range = not (i >= toInteger range_min && i <= toInteger range_max) ppr sty (MachFloat f) - | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f] - | otherwise = ppBesides [ppPStr SLIT("_float_"), ppRational f] + | codeStyle sty = hcat [ppCast sty SLIT("(StgFloat)"), rational f] + | otherwise = hcat [ptext SLIT("_float_ "), rational f] - ppr sty (MachDouble d) = ppRational d + ppr sty (MachDouble d) = rational d ppr sty (MachAddr p) - | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p] - | otherwise = ppBesides [ppPStr SLIT("_addr_"), ppInteger p] + | codeStyle sty = hcat [ppCast sty SLIT("(void*)"), integer p] + | otherwise = hcat [ptext SLIT("_addr_ "), integer p] ppr sty lit@(NoRepInteger i _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppPStr SLIT("_integer_"), ppInteger i] + | otherwise = hsep [ptext SLIT("_integer_ "), integer i] ppr sty lit@(NoRepRational r _) | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit) - | otherwise = ppCat [ppPStr SLIT("_rational_"), ppInteger (numerator r), ppInteger (denominator r)] + | otherwise = hsep [ptext SLIT("_rational_ "), integer (numerator r), integer (denominator r)] ppr sty (MachLitLit s k) - | codeStyle sty = ppPStr s - | otherwise = ppBesides [ppPStr SLIT("_litlit_ "), ppPrimRep k, ppStr " \"", ppPStr s, ppChar '"'] + | codeStyle sty = ptext s + | otherwise = hcat [ptext SLIT("_litlit_ "), ppPrimRep k, char ' ', text (show (_UNPK_ s))] showLiteral :: PprStyle -> Literal -> String -showLiteral sty lit = ppShow 80 (ppr sty lit) +showLiteral sty lit = show (ppr sty lit) \end{code} diff --git a/ghc/compiler/basicTypes/Name.hi-boot b/ghc/compiler/basicTypes/Name.hi-boot new file mode 100644 index 0000000..35861ba --- /dev/null +++ b/ghc/compiler/basicTypes/Name.hi-boot @@ -0,0 +1,8 @@ +_interface_ Name 1 +_usages_ +FastString 1 :: FastString 1; +_exports_ +Name Name Module; +_declarations_ +1 data Name; +1 type Module = FastString.FastString; diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index ee1dfa6..7304c35 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,7 +13,7 @@ module Name ( -- The OccName type OccName(..), - pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, + pprOccName, occNameString, occNameFlavour, isTvOcc, isTCOcc, isVarOcc, prefixOccName, quoteInText, parenInCode, @@ -27,8 +27,10 @@ module Name ( maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, - nameUnique, changeUnique, setNameProvenance, setNameVisibility, - nameOccName, nameString, + nameUnique, changeUnique, setNameProvenance, getNameProvenance, + setNameVisibility, + nameOccName, nameString, nameModule, + isExportedName, nameSrcLoc, isLocallyDefinedName, @@ -37,7 +39,7 @@ module Name ( pprNameProvenance, -- Sets of Names - NameSet(..), + SYN_IE(NameSet), emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, minusNameSet, elemNameSet, nameSetToList, addListToNameSet, isEmptyNameSet, @@ -49,13 +51,11 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), modAndOcc, isExported, - getSrcLoc, isLocallyDefined, getOccString, - - pprSym, pprNonSym + getSrcLoc, isLocallyDefined, getOccString ) where IMP_Ubiq() -import TyLoop ( GenId, Id(..), TyCon ) -- Used inside Names +import TyLoop --( GenId, Id(..), TyCon ) -- Used inside Names import CStrings ( identToC, modnameToC, cSEP ) import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC ) @@ -65,11 +65,13 @@ import PrelMods ( gHC__ ) import Pretty import Lex ( isLexSym, isLexConId ) import SrcLoc ( noSrcLoc, SrcLoc ) +import Usage ( SYN_IE(UVar), SYN_IE(Usage) ) import Unique ( pprUnique, showUnique, Unique ) import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet ) -import UniqFM ( UniqFM ) -import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) +import UniqFM ( UniqFM, SYN_IE(Uniquable) ) +import Util --( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) + \end{code} @@ -89,14 +91,13 @@ data OccName = VarOcc FAST_STRING -- Variables and data constructors moduleString :: Module -> String moduleString mod = _UNPK_ mod -pprModule :: PprStyle -> Module -> Pretty -pprModule sty m = ppPStr m +pprModule :: PprStyle -> Module -> Doc +pprModule sty m = ptext m -pprOccName :: PprStyle -> OccName -> Pretty -pprOccName PprDebug n = ppCat [ppPStr (occNameString n), ppBracket (ppStr (occNameFlavour n))] +pprOccName :: PprStyle -> OccName -> Doc pprOccName sty n = if codeStyle sty then identToC (occNameString n) - else ppPStr (occNameString n) + else ptext (occNameString n) occNameString :: OccName -> FAST_STRING occNameString (VarOcc s) = s @@ -161,19 +162,6 @@ parenInCode, quoteInText :: OccName -> Bool parenInCode occ = isLexSym (occNameString occ) quoteInText occ = not (isLexSym (occNameString occ)) - --- print `vars`, (op) correctly -pprSymOcc, pprNonSymOcc :: PprStyle -> OccName -> Pretty - -pprSymOcc sty var - = if quoteInText var - then ppQuote (pprOccName sty var) - else pprOccName sty var - -pprNonSymOcc sty var - = if parenInCode var - then ppParens (pprOccName sty var) - else pprOccName sty var \end{code} %************************************************************************ @@ -274,6 +262,10 @@ setNameProvenance :: Name -> Provenance -> Name -- Implicit Globals only setNameProvenance (Global uniq mod occ def Implicit) prov = Global uniq mod occ def prov setNameProvenance other_name prov = other_name +getNameProvenance :: Name -> Provenance +getNameProvenance (Global uniq mod occ def prov) = prov +getNameProvenance (Local uniq occ locn) = LocalDef NotExported locn + -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. @@ -314,6 +306,7 @@ all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make th nameUnique :: Name -> Unique nameModAndOcc :: Name -> (Module, OccName) -- Globals only nameOccName :: Name -> OccName +nameModule :: Name -> Module nameString :: Name -> FAST_STRING -- A.b form nameSrcLoc :: Name -> SrcLoc isLocallyDefinedName :: Name -> Bool @@ -329,6 +322,8 @@ nameUnique (Global u _ _ _ _) = u nameOccName (Local _ occ _) = occ nameOccName (Global _ _ occ _ _) = occ +nameModule (Global _ mod occ _ _) = mod + nameModAndOcc (Global _ mod occ _ _) = (mod,occ) nameString (Local _ occ _) = occNameString occ @@ -414,37 +409,47 @@ instance NamedThing Name where \begin{code} instance Outputable Name where + ppr PprQuote name@(Local _ _ _) = quotes (ppr PprForUser name) + ppr PprForUser (Local _ n _) = ptext (occNameString n) + ppr sty (Local u n _) | codeStyle sty || ifaceStyle sty = pprUnique u - ppr PprForUser (Local _ n _) = ppPStr (occNameString n) - ppr other_sty (Local u n _) = ppBesides [ppPStr (occNameString n), ppPStr SLIT("_"), pprUnique u] - - ppr sty name@(Global u m n _ _) = ppBesides [pp_name, pp_debug sty name] - where - pp_name | codeStyle sty = identToC qual_name - | otherwise = ppBesides[ ppPStr m, ppChar '.', ppPStr pk_n] - pk_n = occNameString n - qual_name = m _APPEND_ SLIT(".") _APPEND_ pk_n - -pp_debug PprDebug (Global uniq m n _ prov) = ppBesides [ppStr "{-", pprUnique uniq, ppChar ',', - pp_prov prov, ppStr "-}"] + + ppr sty (Local u n _) = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] + + ppr PprQuote name@(Global _ _ _ _ _) = quotes (ppr PprForUser name) + + ppr sty name@(Global u m n _ _) + | codeStyle sty + = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) + + ppr sty name@(Global u m n _ prov) + = hcat [pp_mod, ptext (occNameString n), pp_debug sty name] + where + pp_mod = case prov of --- Omit home module qualifier + LocalDef _ _ -> empty + other -> pprModule PprForUser m <> char '.' + + +pp_debug PprDebug (Global uniq m n _ prov) = hcat [text "{-", pprUnique uniq, char ',', + pp_prov prov, text "-}"] where - pp_prov (LocalDef Exported _) = ppChar 'x' - pp_prov (LocalDef NotExported _) = ppChar 'l' - pp_prov (Imported _ _) = ppChar 'i' - pp_prov Implicit = ppChar 'p' -pp_debug other name = ppNil + pp_prov (LocalDef Exported _) = char 'x' + pp_prov (LocalDef NotExported _) = char 'l' + pp_prov (Imported _ _) = char 'i' + pp_prov Implicit = char 'p' +pp_debug other name = empty -- pprNameProvenance is used in error messages to say where a name came from -pprNameProvenance :: PprStyle -> Name -> Pretty +pprNameProvenance :: PprStyle -> Name -> Doc pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc) pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov -pprProvenance :: PprStyle -> Provenance -> Pretty +pprProvenance :: PprStyle -> Provenance -> Doc pprProvenance sty (Imported mod loc) - = ppSep [ppPStr SLIT("Imported from"), pprModule sty mod, ppPStr SLIT("at"), ppr sty loc] + = sep [ptext SLIT("Imported from"), pprModule sty mod, ptext SLIT("at"), ppr sty loc] pprProvenance sty (LocalDef _ loc) - = ppSep [ppPStr SLIT("Defined at"), ppr sty loc] + = sep [ptext SLIT("Defined at"), ppr sty loc] pprProvenance sty Implicit = panic "pprNameProvenance: Implicit" \end{code} @@ -499,17 +504,17 @@ class NamedThing a where \begin{code} modAndOcc :: NamedThing a => a -> (Module, OccName) +getModule :: NamedThing a => a -> Module getSrcLoc :: NamedThing a => a -> SrcLoc isLocallyDefined :: NamedThing a => a -> Bool isExported :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String modAndOcc = nameModAndOcc . getName +getModule = nameModule . getName isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName -pprSym sty = pprSymOcc sty . getOccName -pprNonSym sty = pprNonSymOcc sty . getOccName getOccString x = _UNPK_ (occNameString (getOccName x)) \end{code} diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index eee6ee9..a235066 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -25,10 +25,20 @@ module PprEnv ( IMP_Ubiq(){-uitous-} -import Pretty ( SYN_IE(Pretty) ) -import Unique ( initRenumberingUniques ) -import UniqFM ( emptyUFM ) +import Pretty ( Doc ) +import Outputable +import Unique ( initRenumberingUniques, Unique ) +import UniqFM ( emptyUFM, UniqFM ) import Util ( panic ) +#if __GLASGOW_HASKELL__ >= 202 +IMPORT_DELOOPER(TyLoop) +import PprStyle ( PprStyle ) +import Literal ( Literal ) +import Usage ( GenUsage, SYN_IE(Usage) ) +import {-# SOURCE #-} PrimOp (PrimOp) +import {-# SOURCE #-} CostCentre ( CostCentre ) +#endif + \end{code} For tyvars and uvars, we {\em do} normally use these homogenized @@ -40,39 +50,39 @@ uncontrollably from changing Unique-based names. data PprEnv tyvar uvar bndr occ = PE PprStyle -- stored for safe keeping - (Literal -> Pretty) -- Doing these this way saves - (Id -> Pretty) -- carrying around a PprStyle - (PrimOp -> Pretty) - (CostCentre -> Pretty) + (Literal -> Doc) -- Doing these this way saves + (Id -> Doc) -- carrying around a PprStyle + (PrimOp -> Doc) + (CostCentre -> Doc) - (tyvar -> Pretty) -- to print tyvar binders - (tyvar -> Pretty) -- to print tyvar occurrences + (tyvar -> Doc) -- to print tyvar binders + (tyvar -> Doc) -- to print tyvar occurrences - (uvar -> Pretty) -- to print usage vars + (uvar -> Doc) -- to print usage vars - (bndr -> Pretty) -- to print "major" val_bdrs - (bndr -> Pretty) -- to print "minor" val_bdrs - (occ -> Pretty) -- to print bindees + (bndr -> Doc) -- to print "major" val_bdrs + (bndr -> Doc) -- to print "minor" val_bdrs + (occ -> Doc) -- to print bindees - (GenType tyvar uvar -> Pretty) - (GenUsage uvar -> Pretty) + (GenType tyvar uvar -> Doc) + (GenUsage uvar -> Doc) \end{code} \begin{code} initPprEnv :: PprStyle - -> Maybe (Literal -> Pretty) - -> Maybe (Id -> Pretty) - -> Maybe (PrimOp -> Pretty) - -> Maybe (CostCentre -> Pretty) - -> Maybe (tyvar -> Pretty) - -> Maybe (tyvar -> Pretty) - -> Maybe (uvar -> Pretty) - -> Maybe (bndr -> Pretty) - -> Maybe (bndr -> Pretty) - -> Maybe (occ -> Pretty) - -> Maybe (GenType tyvar uvar -> Pretty) - -> Maybe (GenUsage uvar -> Pretty) + -> Maybe (Literal -> Doc) + -> Maybe (Id -> Doc) + -> Maybe (PrimOp -> Doc) + -> Maybe (CostCentre -> Doc) + -> Maybe (tyvar -> Doc) + -> Maybe (tyvar -> Doc) + -> Maybe (uvar -> Doc) + -> Maybe (bndr -> Doc) + -> Maybe (bndr -> Doc) + -> Maybe (occ -> Doc) + -> Maybe (GenType tyvar uvar -> Doc) + -> Maybe (GenUsage uvar -> Doc) -> PprEnv tyvar uvar bndr occ -- you can specify all the printers individually; if @@ -103,7 +113,7 @@ initPprEnv sty pmaj pmin pocc = PE (ppr sty) -- for a Literal (ppr sty) -- for a DataCon (ppr sty) -- for a PrimOp - (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre + (\ cc -> text (showCostCentre sty True cc)) -- CostCentre (ppr sty) -- for a tyvar (ppr sty) -- for a usage var diff --git a/ghc/compiler/basicTypes/PragmaInfo.lhs b/ghc/compiler/basicTypes/PragmaInfo.lhs index b1bf499..d7f514a 100644 --- a/ghc/compiler/basicTypes/PragmaInfo.lhs +++ b/ghc/compiler/basicTypes/PragmaInfo.lhs @@ -14,5 +14,11 @@ IMP_Ubiq() \begin{code} data PragmaInfo = NoPragmaInfo + | IWantToBeINLINEd + + | IMustNotBeINLINEd -- Used by the simplifier to prevent looping + -- on recursive definitions + + | IMustBeINLINEd -- Absolutely must inline; used for PrimOps only \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index e745378..4261e5d 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -10,7 +10,7 @@ \begin{code} #include "HsVersions.h" -module SrcLoc ( +module SrcLoc {- ( SrcLoc, -- Abstract mkSrcLoc, @@ -22,12 +22,14 @@ module SrcLoc ( mkBuiltinSrcLoc, -- Something wired into the compiler mkGeneratedSrcLoc -- Code generated within the compiler - ) where + ) -} where IMP_Ubiq() -import PprStyle ( PprStyle(..) ) +import Outputable +import PprStyle ( PprStyle(..), userStyle ) import Pretty + \end{code} %************************************************************************ @@ -80,19 +82,20 @@ isNoSrcLoc other = False \begin{code} instance Outputable SrcLoc where - ppr PprForUser (SrcLoc src_file src_line) - = ppBesides [ ppPStr src_file, ppChar ':', ppStr (show IBOX(src_line)) ] - ppr sty (SrcLoc src_file src_line) - = ppBesides [ppStr "{-# LINE ", ppStr (show IBOX(src_line)), ppSP, - ppChar '\"', ppPStr src_file, ppStr " #-}"] - ppr sty (UnhelpfulSrcLoc s) = ppPStr s + | userStyle sty + = hcat [ ptext src_file, char ':', text (show IBOX(src_line)) ] + + | otherwise + = hcat [text "{-# LINE ", text (show IBOX(src_line)), space, + char '\"', ptext src_file, text " #-}"] + ppr sty (UnhelpfulSrcLoc s) = ptext s - ppr sty NoSrcLoc = ppStr "" + ppr sty NoSrcLoc = text "" \end{code} {- - = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP, - ppChar '"', ppPStr src_file, ppPStr SLIT(" #-}")] - --ppPStr SLIT("\" #-}")] + = hcat [ptext SLIT("{-# LINE "), text (show IBOX(src_line)), space, + char '"', ptext src_file, ptext SLIT(" #-}")] + --ptext SLIT("\" #-}")] -} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index c60a989..98e2888 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -26,11 +26,16 @@ IMP_Ubiq(){-uitous-} import Unique import Util -import PreludeGlaST -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 +import PreludeGlaST # define WHASH GHCbase.W# +#elif __GLASGOW_HASKELL__ >= 202 +import GlaExts +import STBase +# define WHASH GlaExts.W# #else +import PreludeGlaST # define WHASH W# #endif @@ -92,11 +97,13 @@ mkSplitUniqSupply (C# c#) -- this is the single-most-hammered bit of code -- in the compiler.... -- Too bad it's not 1.3-portable... - unsafe_interleave m s - = let - (r, new_s) = m s - in - (r, s) + unsafe_interleave m = + MkST ( \ s -> + let + (MkST m') = m + (r, new_s) = m' s + in + (r, s)) -- mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) -> @@ -120,7 +127,7 @@ getUniques (I# i) supply = i `get_from` supply where get_from 0# _ = [] get_from n (MkSplitUniqSupply (I# u) _ s2) - = mkUniqueGrimily u : get_from (n `minusInt#` 1#) s2 + = mkUniqueGrimily u : get_from (n -# 1#) s2 \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/Unique.hi-boot b/ghc/compiler/basicTypes/Unique.hi-boot new file mode 100644 index 0000000..237ea4a --- /dev/null +++ b/ghc/compiler/basicTypes/Unique.hi-boot @@ -0,0 +1,6 @@ +_interface_ Unique 1 +_exports_ +Unique Unique mkUniqueGrimily; +_declarations_ +1 data Unique; +1 mkUniqueGrimily _:_ GHC.Int# -> Unique.Unique ;; diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 3dbdbcd..591b27a 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -219,12 +219,25 @@ module Unique ( , parGlobalIdKey , parLocalIdKey , unboundKey + , byteArrayTyConKey + , mutableByteArrayTyConKey + , allClassKey ) where +#if __GLASGOW_HASKELL__ <= 201 import PreludeGlaST +#else +import GlaExts +import ST +#endif IMP_Ubiq(){-uitous-} +#if __GLASGOW_HASKELL__ >= 202 +import {-# SOURCE #-} UniqFM ( Uniquable(..) ) +#endif + +import Outputable import Pretty import Util \end{code} @@ -323,7 +336,7 @@ instance Uniquable Unique where We do sometimes make strings with @Uniques@ in them: \begin{code} -pprUnique, pprUnique10 :: Unique -> Pretty +pprUnique, pprUnique10 :: Unique -> Doc pprUnique uniq = case unpkUnique uniq of @@ -331,24 +344,24 @@ pprUnique uniq pprUnique10 uniq -- in base-10, dudes = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (ppInt u) + (tag, u) -> finish_ppr tag u (int u) finish_ppr tag u pp_u = if tag /= 't' -- this is just to make v common tyvars, t1, t2, ... -- come out as a, b, ... (shorter, easier to read) then pp_all else case u of - 1 -> ppChar 'a' - 2 -> ppChar 'b' - 3 -> ppChar 'c' - 4 -> ppChar 'd' - 5 -> ppChar 'e' + 1 -> char 'a' + 2 -> char 'b' + 3 -> char 'c' + 4 -> char 'd' + 5 -> char 'e' _ -> pp_all where - pp_all = ppBeside (ppChar tag) pp_u + pp_all = (<>) (char tag) pp_u showUnique :: Unique -> FAST_STRING -showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq)) +showUnique uniq = _PK_ (show (pprUnique uniq)) instance Outputable Unique where ppr sty u = pprUnique u @@ -367,12 +380,18 @@ A character-stingy way to read/write numbers (notably Uniques). The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. Code stolen from Lennart. \begin{code} -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 # define BYTE_ARRAY GHCbase.ByteArray # define RUN_ST GHCbase.runST # define AND_THEN >>= # define AND_THEN_ >> # define RETURN return +#elif __GLASGOW_HASKELL__ >= 202 +# define BYTE_ARRAY GlaExts.ByteArray +# define RUN_ST ST.runST +# define AND_THEN >>= +# define AND_THEN_ >> +# define RETURN return #else # define BYTE_ARRAY _ByteArray # define RUN_ST _runST @@ -381,7 +400,7 @@ Code stolen from Lennart. # define RETURN returnStrictlyST #endif -iToBase62 :: Int -> Pretty +iToBase62 :: Int -> Doc iToBase62 n@(I# n#) = ASSERT(n >= 0) @@ -390,11 +409,11 @@ iToBase62 n@(I# n#) in if n# <# 62# then case (indexCharArray# bytes n#) of { c -> - ppChar (C# c) } + char (C# c) } else case (quotRem n 62) of { (q, I# r#) -> case (indexCharArray# bytes r#) of { c -> - ppBeside (iToBase62 q) (ppChar (C# c)) }} + (<>) (iToBase62 q) (char (C# c)) }} -- keep this at top level! (bug on 94/10/24 WDP) chars62 :: BYTE_ARRAY Int @@ -485,6 +504,7 @@ cCallableClassKey = mkPreludeClassUnique 19 cReturnableClassKey = mkPreludeClassUnique 20 ixClassKey = mkPreludeClassUnique 21 +allClassKey = mkPreludeClassUnique 22 -- Pseudo class used for universal quantification \end{code} %************************************************************************ @@ -541,10 +561,10 @@ stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45 stateAndWordPrimTyConKey = mkPreludeTyConUnique 46 statePrimTyConKey = mkPreludeTyConUnique 47 stateTyConKey = mkPreludeTyConUnique 48 - -- 49 is spare +mutableByteArrayTyConKey = mkPreludeTyConUnique 49 stTyConKey = mkPreludeTyConUnique 50 primIoTyConKey = mkPreludeTyConUnique 51 - -- 52 is spare +byteArrayTyConKey = mkPreludeTyConUnique 52 wordPrimTyConKey = mkPreludeTyConUnique 53 wordTyConKey = mkPreludeTyConUnique 54 voidTyConKey = mkPreludeTyConUnique 55 diff --git a/ghc/compiler/codeGen/CGLoop1.hs b/ghc/compiler/codeGen/CGLoop1.hs new file mode 100644 index 0000000..06227bc --- /dev/null +++ b/ghc/compiler/codeGen/CGLoop1.hs @@ -0,0 +1 @@ +module IdLoop () where diff --git a/ghc/compiler/codeGen/CgBindery.hi-boot b/ghc/compiler/codeGen/CgBindery.hi-boot new file mode 100644 index 0000000..a61fc45 --- /dev/null +++ b/ghc/compiler/codeGen/CgBindery.hi-boot @@ -0,0 +1,12 @@ +_interface_ CgBindery 1 +_exports_ +CgBindery CgBindings CgIdInfo(MkCgIdInfo) VolatileLoc StableLoc LambdaFormInfo nukeVolatileBinds maybeAStkLoc maybeBStkLoc; +_declarations_ +1 type CgBindings = Id.IdEnv CgIdInfo; +1 data CgIdInfo = MkCgIdInfo Id.Id CgBindery.VolatileLoc CgBindery.StableLoc CgBindery.LambdaFormInfo; +1 data VolatileLoc; +1 data StableLoc; +1 data LambdaFormInfo; +1 nukeVolatileBinds _:_ CgBindery.CgBindings -> CgBindery.CgBindings ;; +1 maybeAStkLoc _:_ CgBindery.StableLoc -> PrelBase.Maybe HeapOffs.VirtualSpAOffset ;; +1 maybeBStkLoc _:_ CgBindery.StableLoc -> PrelBase.Maybe HeapOffs.VirtualSpBOffset ;; diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 452466b..a5feb79 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -27,7 +27,7 @@ module CgBindery ( ) where IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking +--IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking import AbsCSyn import CgMonad @@ -41,16 +41,21 @@ import HeapOffs ( SYN_IE(VirtualHeapOffset), import Id ( idPrimRep, toplevelishId, isDataCon, mkIdEnv, rngIdEnv, SYN_IE(IdEnv), idSetToList, - GenId{-instance NamedThing-} + GenId{-instance NamedThing-}, SYN_IE(Id) ) +import Literal ( Literal ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} ) +import Name ( isLocallyDefined, isWiredInName, + Name{-instance NamedThing-}, NamedThing(..) ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif import PprStyle ( PprStyle(..) ) +import Pretty ( Doc ) +import PrimRep ( PrimRep ) import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) ) -import Unpretty ( uppShow ) +import Unique ( Unique ) +import UniqFM ( Uniquable(..) ) import Util ( zipWithEqual, panic ) \end{code} @@ -197,7 +202,7 @@ getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id | not (isLocallyDefined name) || isWiredInName name {- Why the "isWiredInName"? - Imagine you are compiling GHCbase.hs (a module that + Imagine you are compiling PrelBase.hs (a module that supplies some of the wired-in values). What can happen is that the compiler will inject calls to (e.g.) GHCbase.unpackPS, where-ever it likes -- it @@ -410,7 +415,7 @@ bindNewPrimToAmode name (CVal (NodeRel offset) _) #ifdef DEBUG bindNewPrimToAmode name amode - = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode))) + = panic ("bindNew...:"++(show (pprAmode PprDebug amode))) #endif \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 939c87d..ed5cc8e 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -45,16 +45,19 @@ import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, ) import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) -import CostCentre ( useCurrentCostCentre ) +import CostCentre ( useCurrentCostCentre, CostCentre ) import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) ) import Id ( idPrimRep, toplevelishId, dataConTag, fIRST_TAG, SYN_IE(ConTag), isDataCon, SYN_IE(DataCon), - idSetToList, GenId{-instance Uniquable,Eq-} + idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id) ) +import Literal ( Literal ) import Maybes ( catMaybes ) +import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) +import Pretty ( Doc ) import PrimOp ( primOpCanTriggerGC, PrimOp(..), primOpStackRequired, StackRequirement(..) ) @@ -64,11 +67,15 @@ import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, import TyCon ( isEnumerationTyCon ) import Type ( typePrimRep, getAppSpecDataTyConExpandingDicts, - maybeAppSpecDataTyConExpandingDicts + maybeAppSpecDataTyConExpandingDicts, + SYN_IE(Type) ) +import Unique ( Unique ) +import UniqFM ( Uniquable(..) ) import Util ( sortLt, isIn, isn'tIn, zipEqual, pprError, panic, assertPanic ) + \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 872827f..39d484c 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -49,24 +49,24 @@ import ClosureInfo -- lots and lots of stuff import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros ) import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, noCostCentreAttached, costsAreSubsumed, - isCafCC, isDictCC, overheadCostCentre, showCostCentre + isCafCC, isDictCC, overheadCostCentre, showCostCentre, + CostCentre ) import HeapOffs ( SYN_IE(VirtualHeapOffset) ) import Id ( idType, idPrimRep, showId, getIdStrictness, dataConTag, emptyIdSet, - GenId{-instance Outputable-} + GenId{-instance Outputable-}, SYN_IE(Id) ) import ListSetOps ( minusList ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} ) -import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr ) +import Pretty ( Doc, hcat, char, ptext, hsep, text ) import PrimRep ( isFollowableRep, PrimRep(..) ) import TyCon ( isPrimTyCon, tyConDataCons ) import Type ( showTypeCategory ) -import Unpretty ( uppShow ) import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} ) getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)" @@ -602,7 +602,7 @@ enterCostCentreCode closure_info cc is_thunk if costsAreSubsumed cc then --ASSERT(isToplevClosure closure_info) --ASSERT(is_thunk == IsFunction) - (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $ + (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, text (showCostCentre PprDebug False cc)])) $ costCentresC SLIT("ENTER_CC_FSUB") [] else if currentOrSubsumedCosts cc then @@ -915,12 +915,12 @@ closureDescription :: FAST_STRING -- Module -- CgConTbls.lhs with a description generated from the data constructor closureDescription mod_name name args body - = uppShow 0 (prettyToUn ( - ppBesides [ppChar '<', - ppPStr mod_name, - ppChar '.', + = show ( + hcat [char '<', + ptext mod_name, + char '.', ppr PprDebug name, - ppChar '>'])) + char '>']) \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 2ae485e..a411043 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -41,11 +41,11 @@ import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, layOutStaticClosure ) import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre, - dontCareCostCentre + dontCareCostCentre, CostCentre ) import Id ( idPrimRep, dataConTag, dataConTyCon, isDataCon, SYN_IE(DataCon), - emptyIdSet + emptyIdSet, SYN_IE(Id) ) import Literal ( Literal(..) ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index c970c9f..09d9c10 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -29,21 +29,22 @@ import CLabel ( mkConEntryLabel, mkStaticClosureLabel, import ClosureInfo ( layOutStaticClosure, layOutDynCon, layOutPhantomClosure, closurePtrsSize, fitsMinUpdSize, mkConLFInfo, - infoTableLabelFromCI, dataConLiveness + infoTableLabelFromCI, dataConLiveness, + ClosureInfo ) -import CostCentre ( dontCareCostCentre ) +import CostCentre ( dontCareCostCentre, CostCentre ) import FiniteMap ( fmToList, FiniteMap ) import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) ) import Id ( dataConTag, dataConRawArgTys, dataConNumFields, fIRST_TAG, emptyIdSet, - GenId{-instance NamedThing-} + GenId{-instance NamedThing-}, SYN_IE(Id) ) import Name ( getOccString ) import PrelInfo ( maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import TyCon ( tyConDataCons, mkSpecTyCon ) -import Type ( typePrimRep ) +import TyCon ( tyConDataCons, mkSpecTyCon, TyCon ) +import Type ( typePrimRep, SYN_IE(Type) ) import Util ( panic ) mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)" diff --git a/ghc/compiler/codeGen/CgExpr.hi-boot b/ghc/compiler/codeGen/CgExpr.hi-boot new file mode 100644 index 0000000..6398db2 --- /dev/null +++ b/ghc/compiler/codeGen/CgExpr.hi-boot @@ -0,0 +1,6 @@ +_interface_ CgExpr 1 +_exports_ +CgExpr cgExpr getPrimOpArgAmodes; +_declarations_ +1 cgExpr _:_ StgSyn.StgExpr -> CgMonad.Code ;; +1 getPrimOpArgAmodes _:_ PrimOp.PrimOp -> [StgSyn.StgArg] -> CgMonad.FCode [AbsCSyn.CAddrMode] ;; diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index c9a6dc7..d90f988 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -35,16 +35,18 @@ import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode, mkPrimReturnCode ) import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) -import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, lfArity_maybe, +import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, layOutDynCon ) import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre ) import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods ) import Id ( dataConTyCon, idPrimRep, getIdArity, - mkIdSet, unionIdSets, GenId{-instance Outputable-} + mkIdSet, unionIdSets, GenId{-instance Outputable-}, + SYN_IE(Id) ) import IdInfo ( ArityInfo(..) ) import Name ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) +import Pretty ( Doc ) import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) ) @@ -52,6 +54,9 @@ import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, maybeTyConSingleCon ) import Maybes ( assocMaybe, maybeToBool ) import Util ( panic, isIn, pprPanic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif \end{code} This module provides the support code for @StgToAbstractC@ to deal @@ -312,8 +317,10 @@ cgRhs name (StgRhsCon maybe_cc con args) zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body) - = mkRhsLFInfo fvs upd_flag args body `thenFC` \ lf_info -> - cgRhsClosure name cc bi fvs args body lf_info + = cgRhsClosure name cc bi fvs args body lf_info + where + lf_info = mkRhsLFInfo fvs upd_flag args body + \end{code} mkRhsLFInfo looks for two special forms of the right-hand side: @@ -322,8 +329,13 @@ mkRhsLFInfo looks for two special forms of the right-hand side: If neither happens, it just calls mkClosureLFInfo. You might think that mkClosureLFInfo should do all this, but + (a) it seems wrong for the latter to look at the structure of an expression + + [March 97: item (b) is no longer true, but I've left mkRhsLFInfo here + anyway because of (a).] + (b) mkRhsLFInfo has to be in the monad since it looks up in the environment, and it's very tiresome for mkClosureLFInfo to be. Apart from anything else it would make a loop between @@ -355,7 +367,7 @@ mkRhsLFInfo [the_fv] -- Just one free var && maybeToBool offset_into_int_maybe && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough = -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon - returnFC (mkSelectorLFInfo scrutinee con offset_into_int) + mkSelectorLFInfo scrutinee con offset_into_int where (_, params_w_offsets) = layOutDynCon con idPrimRep params maybe_offset = assocMaybe params_w_offsets selectee @@ -381,26 +393,13 @@ mkRhsLFInfo fvs [] -- No args; a thunk (StgApp (StgVarArg fun_id) args _) | isLocallyDefined fun_id -- Must be defined in this module - = -- Get the arity of the fun_id. We could find out from the - -- looking in the Id, but it's more certain just to look in the code - -- generator's environment. - ----------------------------------------------- --- Sadly, looking in the environment, as suggested above, --- causes a black hole (because cgRhsClosure depends on the LFInfo --- returned here to determine its control flow. --- So I wimped out and went back to looking at the arity inside the Id. --- That means beefing up Core2Stg to propagate it. Sigh. --- getCAddrModeAndInfo fun_id `thenFC` \ (_, fun_lf_info) -> --- let arity_maybe = lfArity_maybe fun_lf_info ----------------------------------------------- - + = -- Get the arity of the fun_id. It's guaranteed to be correct (by setStgVarInfo). let arity_maybe = case getIdArity fun_id of ArityExactly n -> Just n other -> Nothing in - returnFC (case arity_maybe of + case arity_maybe of Just arity | arity > 0 && -- It'd better be a function! arity == length args -- Saturated application @@ -408,8 +407,6 @@ mkRhsLFInfo fvs mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap other -> mkClosureLFInfo False{-not top level-} fvs upd_flag [] - ) - where -- If the function is a free variable then it must be stored -- in the thunk too; if it isn't a free variable it must be @@ -422,7 +419,7 @@ The default case ~~~~~~~~~~~~~~~~ \begin{code} mkRhsLFInfo fvs upd_flag args body - = returnFC (mkClosureLFInfo False{-not top level-} fvs upd_flag args) + = mkClosureLFInfo False{-not top level-} fvs upd_flag args \end{code} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 1e7b2c9..903d072 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -24,10 +24,10 @@ import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp, initHeapUsage ) import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, - slopSize, allocProfilingMsg, closureKind + slopSize, allocProfilingMsg, closureKind, ClosureInfo ) import HeapOffs ( isZeroOff, addOff, intOff, - SYN_IE(VirtualHeapOffset) + SYN_IE(VirtualHeapOffset), HeapOffset ) import PrimRep ( PrimRep(..) ) \end{code} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 591e775..c3ee85b 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -29,8 +29,9 @@ import CgStackery ( mkVirtStkOffsets ) import CgUsages ( setRealAndVirtualSps, getVirtSps ) import CLabel ( mkStdEntryLabel ) import ClosureInfo ( mkLFLetNoEscape ) +import CostCentre ( CostCentre ) import HeapOffs ( SYN_IE(VirtualSpBOffset) ) -import Id ( idPrimRep ) +import Id ( idPrimRep, SYN_IE(Id) ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgLoop1.hs b/ghc/compiler/codeGen/CgLoop1.hs new file mode 100644 index 0000000..b5cd421 --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop1.hs @@ -0,0 +1,9 @@ +module CgLoop1 + + ( + module CgBindery, + module CgUsages + ) where + +import CgBindery +import CgUsages diff --git a/ghc/compiler/codeGen/CgLoop2.hs b/ghc/compiler/codeGen/CgLoop2.hs new file mode 100644 index 0000000..dc42921 --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop2.hs @@ -0,0 +1,7 @@ +module CgLoop2 + + ( + module CgExpr + ) where + +import CgExpr diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 18902fc..c7e18cd 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -57,22 +57,28 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling, opt_OmitBlackHoling ) import HeapOffs ( maxOff, - SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) + SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), + HeapOffset ) +import CLabel ( CLabel ) import Id ( idType, nullIdEnv, mkIdEnv, addOneToIdEnv, modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv), - SYN_IE(ConTag), GenId{-instance Outputable-} + SYN_IE(ConTag), GenId{-instance Outputable-}, + SYN_IE(Id) ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppAboves, ppCat, ppPStr ) +import Pretty ( Doc, vcat, hsep, ptext ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import StgSyn ( SYN_IE(StgLiveVars) ) import Type ( typePrimRep ) import UniqSet ( elementOfUniqSet ) import Util ( sortLt, panic, pprPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -688,13 +694,13 @@ lookupBindC name info_down@(MkCgInfoDown _ static_binds _) Just this -> this Nothing -> pprPanic "lookupBindC:no info!\n" - (ppAboves [ - ppCat [ppPStr SLIT("for:"), ppr PprShowAll name], - ppPStr SLIT("(probably: data dependencies broken by an optimisation pass)"), - ppPStr SLIT("static binds for:"), - ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], - ppPStr SLIT("local binds for:"), - ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] + (vcat [ + hsep [ptext SLIT("for:"), ppr PprShowAll name], + ptext SLIT("(probably: data dependencies broken by an optimisation pass)"), + ptext SLIT("static binds for:"), + vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], + ptext SLIT("local binds for:"), + vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] ]) \end{code} diff --git a/ghc/compiler/codeGen/CgRetConv.hi-boot b/ghc/compiler/codeGen/CgRetConv.hi-boot new file mode 100644 index 0000000..7be70a8 --- /dev/null +++ b/ghc/compiler/codeGen/CgRetConv.hi-boot @@ -0,0 +1,7 @@ +_interface_ CgRetConv 1 +_exports_ +CgRetConv CtrlReturnConvention(VectoredReturn UnvectoredReturn) ctrlReturnConvAlg; +_declarations_ +1 data CtrlReturnConvention = VectoredReturn PrelBase.Int | UnvectoredReturn PrelBase.Int; +1 ctrlReturnConvAlg _:_ TyCon.TyCon -> CgRetConv.CtrlReturnConvention ;; + diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 6b773f9..60597a7 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -35,7 +35,8 @@ import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, ) import CmdLineOpts ( opt_ReturnInRegsThreshold ) import Id ( isDataCon, dataConRawArgTys, - SYN_IE(DataCon), GenId{-instance Eq-} + SYN_IE(DataCon), GenId{-instance Eq-}, + SYN_IE(Id) ) import Maybes ( catMaybes ) import PprStyle ( PprStyle(..) ) @@ -47,9 +48,13 @@ import PrimOp ( primOpCanTriggerGC, import PrimRep ( isFloatingRep, PrimRep(..) ) import TyCon ( tyConDataCons, tyConFamilySize ) import Type ( typePrimRep ) +import Pretty ( Doc ) import Util ( zipWithEqual, mapAccumL, isn'tIn, pprError, pprTrace, panic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 136814a..87cd59c 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -32,7 +32,7 @@ import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg, ) import CgStackery ( adjustRealSps, mkStkAmodes ) import CgUsages ( getSpARelOffset ) -import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) +import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel ) import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..), LambdaFormInfo @@ -40,13 +40,14 @@ import ClosureInfo ( nodeMustPointToIt, import CmdLineOpts ( opt_DoSemiTagging ) import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) ) import Id ( idType, dataConTyCon, dataConTag, - fIRST_TAG + fIRST_TAG, SYN_IE(Id) ) import Literal ( mkMachInt ) import Maybes ( assocMaybe ) import PrimRep ( PrimRep(..) ) import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) ) import Type ( isPrimType ) +import TyCon ( TyCon ) import Util ( zipWithEqual, panic, assertPanic ) \end{code} diff --git a/ghc/compiler/codeGen/CgUsages.hi-boot b/ghc/compiler/codeGen/CgUsages.hi-boot new file mode 100644 index 0000000..af1fb46 --- /dev/null +++ b/ghc/compiler/codeGen/CgUsages.hi-boot @@ -0,0 +1,5 @@ +_interface_ CgUsages 1 +_exports_ +CgUsages getSpBRelOffset; +_declarations_ +1 getSpBRelOffset _:_ HeapOffs.VirtualSpBOffset -> CgMonad.FCode AbsCSyn.RegRelative ;; diff --git a/ghc/compiler/codeGen/ClosureInfo.hi-boot b/ghc/compiler/codeGen/ClosureInfo.hi-boot new file mode 100644 index 0000000..fce0a2a --- /dev/null +++ b/ghc/compiler/codeGen/ClosureInfo.hi-boot @@ -0,0 +1,18 @@ +_interface_ ClosureInfo 1 +_exports_ +ClosureInfo ClosureInfo closureKind closureLabelFromCI closureNonHdrSize closurePtrsSize closureSMRep closureSemiTag closureSizeWithoutFixedHdr closureTypeDescr closureUpdReqd entryLabelFromCI fastLabelFromCI infoTableLabelFromCI maybeSelectorInfo; +_declarations_ +1 data ClosureInfo; +1 closureKind _:_ ClosureInfo -> PrelBase.String ;; +1 closureLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;; +1 closureNonHdrSize _:_ ClosureInfo -> PrelBase.Int ;; +1 closurePtrsSize _:_ ClosureInfo -> PrelBase.Int ;; +1 closureSMRep _:_ ClosureInfo -> SMRep.SMRep ;; +1 closureSemiTag _:_ ClosureInfo -> PrelBase.Int ;; +1 closureSizeWithoutFixedHdr _:_ ClosureInfo -> HeapOffs.HeapOffset ;; +1 closureTypeDescr _:_ ClosureInfo -> PrelBase.String ;; +1 closureUpdReqd _:_ ClosureInfo -> PrelBase.Bool ;; +1 entryLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;; +1 fastLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;; +1 infoTableLabelFromCI _:_ ClosureInfo -> CLabel.CLabel ;; +1 maybeSelectorInfo _:_ ClosureInfo -> PrelBase.Maybe (Id.Id, PrelBase.Int) ;; diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index f48aeae..6a7f408 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -28,7 +28,7 @@ module ClosureInfo ( mkVirtHeapOffsets, nodeMustPointToIt, getEntryConvention, - blackHoleOnEntry, lfArity_maybe, + blackHoleOnEntry, staticClosureRequired, slowFunEntryCodeRequired, funInfoTableRequired, @@ -75,14 +75,14 @@ import CLabel ( mkStdEntryLabel, mkFastEntryLabel, ) import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, - SYN_IE(VirtualHeapOffset) + SYN_IE(VirtualHeapOffset), HeapOffset ) import Id ( idType, getIdArity, externallyVisibleId, dataConTag, fIRST_TAG, - isDataCon, isNullaryDataCon, dataConTyCon, dataConArity, + isDataCon, isNullaryDataCon, dataConTyCon, isTupleCon, SYN_IE(DataCon), - GenId{-instance Eq-} + GenId{-instance Eq-}, SYN_IE(Id) ) import IdInfo ( ArityInfo(..) ) import Maybes ( maybeToBool ) @@ -91,13 +91,17 @@ import PprStyle ( PprStyle(..) ) import PprType ( getTyDescription, GenType{-instance Outputable-} ) import Pretty --ToDo:rm import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) -import PrimRep ( getPrimRepSize, separateByPtrFollowness ) +import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it import TyCon ( TyCon{-instance NamedThing-} ) import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking, - mkFunTys, maybeAppSpecDataTyConExpandingDicts + mkFunTys, maybeAppSpecDataTyConExpandingDicts, + SYN_IE(Type) ) import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif \end{code} The ``wrapper'' data type for closure information: @@ -1018,10 +1022,18 @@ noUpdVapRequired binder_info @lfArity@ extracts the arity of a function from its LFInfo \begin{code} +{- Not needed any more + lfArity_maybe (LFReEntrant _ arity _) = Just arity -lfArity_maybe (LFCon con _) = Just (dataConArity con) -lfArity_maybe (LFTuple con _) = Just (dataConArity con) + +-- Removed SLPJ March 97. I don't believe these two; +-- LFCon is used for construcor *applications*, not constructors! +-- +-- lfArity_maybe (LFCon con _) = Just (dataConArity con) +-- lfArity_maybe (LFTuple con _) = Just (dataConArity con) + lfArity_maybe other = Nothing +-} \end{code} %************************************************************************ @@ -1099,7 +1111,7 @@ fun_result_ty arity id (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id) in -- ASSERT(arity >= 0 && length arg_tys >= arity) - (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ + (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (hsep [int arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ mkFunTys (drop arity arg_tys) res_ty \end{code} @@ -1128,9 +1140,16 @@ Label generation. \begin{code} fastLabelFromCI :: ClosureInfo -> CLabel fastLabelFromCI (MkClosureInfo id lf_info _) +{- [SLPJ Changed March 97] + (was ok, but is the only call to lfArity, + and the id should guarantee to have the correct arity in it. + = case lfArity_maybe lf_info of - Just arity -> mkFastEntryLabel id arity - other -> pprPanic "fastLabelFromCI" (ppr PprDebug id) + Just arity -> +-} + = case getIdArity id of + ArityExactly arity -> mkFastEntryLabel id arity + other -> pprPanic "fastLabelFromCI" (ppr PprDebug id) infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI (MkClosureInfo id lf_info rep) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 4f2e585..4865d4e 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -35,10 +35,15 @@ import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals, opt_EnsureSplittableC, opt_SccGroup ) +import CostCentre ( CostCentre ) import CStrings ( modnameToC ) import FiniteMap ( FiniteMap ) +import Id ( SYN_IE(Id) ) import Maybes ( maybeToBool ) +import Name ( SYN_IE(Module) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) +import Type ( SYN_IE(Type) ) +import TyCon ( TyCon ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 7c46adf..78934e8 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -19,8 +19,11 @@ module SMRep ( IMP_Ubiq(){-uitous-} -import Pretty ( ppStr ) +import Pretty ( text ) import Util ( panic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} %************************************************************************ @@ -218,7 +221,7 @@ instance Text SMRep where MuTupleRep _ -> "MUTUPLE") instance Outputable SMRep where - ppr sty rep = ppStr (show rep) + ppr sty rep = text (show rep) getSMInfoStr :: SMRep -> String getSMInfoStr (StaticRep _ _) = "STATIC" diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs index b5ce22a..59db4a5 100644 --- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -21,6 +21,13 @@ module AnnCoreSyn ( IMP_Ubiq(){-uitous-} import CoreSyn + +import Id ( SYN_IE(Id) ) +import Literal ( Literal ) +import PrimOp ( PrimOp ) +import CostCentre ( CostCentre ) +import Type ( GenType ) + \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 2310d02..bb6a323 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -22,13 +22,14 @@ import CoreSyn import CoreUtils ( coreExprType ) import Id ( idType, mkSysLocal, nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), - GenId{-instances-} + GenId{-instances-}, SYN_IE(Id) ) import Name ( isLocallyDefined, getSrcLoc, getOccString ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) import Type ( maybeAppDataTyConExpandingDicts, eqTy ) import TysPrim ( statePrimTyCon ) import TysWiredIn ( liftDataCon, mkLiftTy ) +import Unique ( Unique ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) import Util ( zipEqual, zipWithEqual, assertPanic, panic ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index cff9392..474f505 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,15 +16,18 @@ IMP_Ubiq() import CoreSyn import Bag -import Kind ( hasMoreBoxityInfo, Kind{-instance-} ) +import Kind ( hasMoreBoxityInfo, Kind{-instance-}, + isTypeKind, isBoxedTypeKind {- TEMP --SOF -} ) import Literal ( literalType, Literal{-instance-} ) import Id ( idType, isBottomingId, dataConRepType, dataConArgTys, GenId{-instances-}, emptyIdSet, mkIdSet, intersectIdSets, - unionIdSets, elementOfIdSet, SYN_IE(IdSet) + unionIdSets, elementOfIdSet, SYN_IE(IdSet), + SYN_IE(Id) ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} ) +import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-}, + NamedThing(..) ) import Outputable ( Outputable(..){-instance * []-} ) import PprCore import PprStyle ( PprStyle(..) ) @@ -38,7 +41,7 @@ import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, getForAllTyExpandingDicts_maybe, isPrimType,typeKind,instantiateTy,splitSigmaTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyConExpandingDicts, eqTy + maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type) -- ,expandTy -- ToDo:rm ) import TyCon ( isPrimTyCon ) @@ -91,12 +94,12 @@ lintCoreBindings sty whoDunnit spec_done binds = case (initL (lint_binds binds) spec_done) of Nothing -> binds Just msg -> - pprPanic "" (ppAboves [ - ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), + pprPanic "" (vcat [ + text ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"), msg sty, - ppPStr SLIT("*** Offending Program ***"), - ppAboves (map (pprCoreBinding sty) binds), - ppPStr SLIT("*** End of Offense ***") + ptext SLIT("*** Offending Program ***"), + vcat (map (pprCoreBinding sty) binds), + ptext SLIT("*** End of Offense ***") ]) where lint_binds [] = returnL () @@ -125,10 +128,10 @@ lintUnfolding locn expr Nothing -> Just expr Just msg -> pprTrace "WARNING: Discarded bad unfolding from interface:\n" - (ppAboves [msg PprForUser, - ppPStr SLIT("*** Bad unfolding ***"), + (vcat [msg PprForUser, + ptext SLIT("*** Bad unfolding ***"), ppr PprDebug expr, - ppPStr SLIT("*** End unfolding ***")]) + ptext SLIT("*** End unfolding ***")]) Nothing \end{code} @@ -284,7 +287,8 @@ lintCoreArg e ty a@(TyArg arg_ty) tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty in - if argty_kind `hasMoreBoxityInfo` tyvar_kind + if argty_kind `hasMoreBoxityInfo` tyvar_kind || -- Should the args be swapped here? + (isTypeKind argty_kind && isBoxedTypeKind tyvar_kind) -- (hackily) added SOF -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a @@ -292,7 +296,7 @@ lintCoreArg e ty a@(TyArg arg_ty) then returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) else - pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ + pprTrace "lintCoreArg:kinds:" (hsep [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing lintCoreArg e ty (UsageArg u) @@ -403,7 +407,7 @@ type LintM a = Bool -- True <=> specialisation has been done -> Bag ErrMsg -- Error messages so far -> (a, Bag ErrMsg) -- Result and error messages (if any) -type ErrMsg = PprStyle -> Pretty +type ErrMsg = PprStyle -> Doc data LintLocInfo = RhsOf Id -- The variable bound @@ -413,24 +417,24 @@ data LintLocInfo instance Outputable LintLocInfo where ppr sty (RhsOf v) - = ppBesides [ppr sty (getSrcLoc v), ppPStr SLIT(": [RHS of "), pp_binders sty [v], ppChar ']'] + = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']'] ppr sty (LambdaBodyOf b) - = ppBesides [ppr sty (getSrcLoc b), - ppPStr SLIT(": [in body of lambda with binder "), pp_binder sty b, ppChar ']'] + = hcat [ppr sty (getSrcLoc b), + ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']'] ppr sty (BodyOfLetRec bs) - = ppBesides [ppr sty (getSrcLoc (head bs)), - ppPStr SLIT(": [in body of letrec with binders "), pp_binders sty bs, ppChar ']'] + = hcat [ppr sty (getSrcLoc (head bs)), + ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']'] ppr sty (ImportedUnfolding locn) - = ppBeside (ppr sty locn) (ppPStr SLIT(": [in an imported unfolding]")) + = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]")) -pp_binders :: PprStyle -> [Id] -> Pretty -pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs) +pp_binders :: PprStyle -> [Id] -> Doc +pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs)) -pp_binder :: PprStyle -> Id -> Pretty -pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)] +pp_binder :: PprStyle -> Id -> Doc +pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)] \end{code} \begin{code} @@ -441,7 +445,7 @@ initL m spec_done Nothing else Just ( \ sty -> - ppAboves [ msg sty | msg <- bagToList errs ] + vcat [ msg sty | msg <- bagToList errs ] ) } @@ -507,7 +511,7 @@ addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs = ASSERT (not (null locs)) errs_so_far `snocBag` ( \ sty -> - ppHang (ppr sty (head locs)) 4 (msg sty) + hang (ppr sty (head locs)) 4 (msg sty) ) addLoc :: LintLocInfo -> LintM a -> LintM a @@ -541,7 +545,7 @@ checkInScope id spec loc scope errs id_name = getName id in if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then - ((),addErr errs (\sty -> ppCat [ppr sty id, ppPStr SLIT("is out of scope")]) loc) + ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc) else ((),errs) @@ -553,113 +557,113 @@ checkTys ty1 ty2 msg spec loc scope errs \begin{code} mkCaseAltMsg :: CoreCaseAlts -> ErrMsg mkCaseAltMsg alts sty - = ppAbove (ppPStr SLIT("Type of case alternatives not the same:")) + = ($$) (ptext SLIT("Type of case alternatives not the same:")) (ppr sty alts) mkCaseDataConMsg :: CoreExpr -> ErrMsg mkCaseDataConMsg expr sty - = ppAbove (ppPStr SLIT("A case scrutinee not of data constructor type:")) + = ($$) (ptext SLIT("A case scrutinee not of data constructor type:")) (pp_expr sty expr) mkCaseNotPrimMsg :: TyCon -> ErrMsg mkCaseNotPrimMsg tycon sty - = ppAbove (ppPStr SLIT("A primitive case on a non-primitive type:")) + = ($$) (ptext SLIT("A primitive case on a non-primitive type:")) (ppr sty tycon) mkCasePrimMsg :: TyCon -> ErrMsg mkCasePrimMsg tycon sty - = ppAbove (ppPStr SLIT("An algebraic case on a primitive type:")) + = ($$) (ptext SLIT("An algebraic case on a primitive type:")) (ppr sty tycon) mkCaseAbstractMsg :: TyCon -> ErrMsg mkCaseAbstractMsg tycon sty - = ppAbove (ppPStr SLIT("An algebraic case on some weird type:")) + = ($$) (ptext SLIT("An algebraic case on some weird type:")) (ppr sty tycon) mkDefltMsg :: CoreCaseDefault -> ErrMsg mkDefltMsg deflt sty - = ppAbove (ppPStr SLIT("Binder in case default doesn't match type of scrutinee:")) + = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:")) (ppr sty deflt) mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkAppMsg fun arg expr sty - = ppAboves [ppPStr SLIT("Argument value doesn't match argument type:"), - ppHang (ppPStr SLIT("Fun type:")) 4 (ppr sty fun), - ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), - ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] + = vcat [ptext SLIT("Argument value doesn't match argument type:"), + hang (ptext SLIT("Fun type:")) 4 (ppr sty fun), + hang (ptext SLIT("Arg type:")) 4 (ppr sty arg), + hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg mkTyAppMsg msg ty arg expr sty - = ppAboves [ppCat [ppPStr msg, ppPStr SLIT("type application:")], - ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), - ppHang (ppPStr SLIT("Arg type:")) 4 (ppr sty arg), - ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] + = vcat [hsep [ptext msg, ptext SLIT("type application:")], + hang (ptext SLIT("Exp type:")) 4 (ppr sty ty), + hang (ptext SLIT("Arg type:")) 4 (ppr sty arg), + hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg mkUsageAppMsg ty u expr sty - = ppAboves [ppPStr SLIT("Illegal usage application:"), - ppHang (ppPStr SLIT("Exp type:")) 4 (ppr sty ty), - ppHang (ppPStr SLIT("Usage exp:")) 4 (ppr sty u), - ppHang (ppPStr SLIT("Expression:")) 4 (pp_expr sty expr)] + = vcat [ptext SLIT("Illegal usage application:"), + hang (ptext SLIT("Exp type:")) 4 (ppr sty ty), + hang (ptext SLIT("Usage exp:")) 4 (ppr sty u), + hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)] mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty - = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") + = ($$) (text "In some case statement, type of scrutinee is not a data type:") (ppr sty ty) --- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm +-- (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm mkAlgAltMsg2 :: Type -> Id -> ErrMsg mkAlgAltMsg2 ty con sty - = ppAboves [ - ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + = vcat [ + text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", ppr sty ty, ppr sty con ] mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg mkAlgAltMsg3 con alts sty - = ppAboves [ - ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:", + = vcat [ + text "In some algebraic case alternative, number of arguments doesn't match constructor:", ppr sty con, ppr sty alts ] mkAlgAltMsg4 :: Type -> Id -> ErrMsg mkAlgAltMsg4 ty arg sty - = ppAboves [ - ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:", + = vcat [ + text "In some algebraic case alternative, type of argument doesn't match data constructor:", ppr sty ty, ppr sty arg ] mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg mkPrimAltMsg alt sty - = ppAbove - (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:") + = ($$) + (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:") (ppr sty alt) mkRhsMsg :: Id -> Type -> ErrMsg mkRhsMsg binder ty sty - = ppAboves - [ppCat [ppPStr SLIT("The type of this binder doesn't match the type of its RHS:"), + = vcat + [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), ppr sty binder], - ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)], - ppCat [ppPStr SLIT("Rhs type:"), ppr sty ty]] + hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)], + hsep [ptext SLIT("Rhs type:"), ppr sty ty]] mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg mkRhsPrimMsg binder rhs sty - = ppAboves [ppCat [ppPStr SLIT("The type of this binder is primitive:"), + = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), ppr sty binder], - ppCat [ppPStr SLIT("Binder's type:"), ppr sty (idType binder)] + hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)] ] mkSpecTyAppMsg :: CoreArg -> ErrMsg mkSpecTyAppMsg arg sty - = ppAbove - (ppPStr SLIT("Unboxed types in a type application (after specialisation):")) + = ($$) + (ptext SLIT("Unboxed types in a type application (after specialisation):")) (ppr sty arg) -pp_expr :: PprStyle -> CoreExpr -> Pretty +pp_expr :: PprStyle -> CoreExpr -> Doc pp_expr sty expr = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index e16b6d9..6e28cf4 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -56,10 +56,16 @@ module CoreSyn ( IMP_Ubiq(){-uitous-} import CostCentre ( showCostCentre, CostCentre ) -import Id ( idType, GenId{-instance Eq-} ) -import Type ( isUnboxedType ) -import Usage ( SYN_IE(UVar) ) +import Id ( idType, GenId{-instance Eq-}, SYN_IE(Id) ) +import Type ( isUnboxedType,GenType, SYN_IE(Type) ) +import TyVar ( GenTyVar, SYN_IE(TyVar) ) +import Usage ( SYN_IE(UVar),GenUsage,SYN_IE(Usage) ) import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Literal ( Literal ) +import BinderInfo ( BinderInfo ) +import PrimOp ( PrimOp ) +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot new file mode 100644 index 0000000..2c20727 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot @@ -0,0 +1,8 @@ +_interface_ CoreUnfold 1 +_exports_ +CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding; +_declarations_ +1 data Unfolding; +1 data UnfoldingGuidance; +1 mkUnfolding _:_ PragmaInfo.PragmaInfo -> CoreSyn.CoreExpr -> CoreUnfold.Unfolding ;; +1 noUnfolding _:_ CoreUnfold.Unfolding ;; diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index f2077ba..f15a370 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -19,20 +19,23 @@ module CoreUnfold ( SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types UfExpr, RdrName, -- For closure (delete in 1.3) - FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, + FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup, exprIsTrivial, noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline, okToInline, - calcUnfoldingGuidance + calcUnfoldingGuidance, + + PragmaInfo(..) -- Re-export ) where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) -- for paranoia checking; -- and also to get mkMagicUnfoldingFun IMPORT_DELOOPER(PrelLoop) -- for paranoia checking +IMPORT_DELOOPER(SmplLoop) import Bag ( emptyBag, unitBag, unionBags, Bag ) @@ -45,13 +48,14 @@ import Constants ( uNFOLDING_CHEAP_OP_COST, uNFOLDING_NOREP_LIT_COST ) import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger ) +import PragmaInfo ( PragmaInfo(..) ) import CoreSyn import CoreUtils ( unTagBinders ) import HsCore ( UfExpr ) import RdrHsSyn ( RdrName ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( coreExprType ) -import CostCentre ( ccMentionsId ) +--import CostCentre ( ccMentionsId ) import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe, SYN_IE(IdSet), GenId{-instances-} ) import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) @@ -60,13 +64,17 @@ import Literal ( isNoRepLit, isLitLitLit ) import Pretty import TyCon ( tyConFamilySize ) import Type ( maybeAppDataTyConExpandingDicts ) +import Unique ( Unique ) import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, unionUniqSets ) import Usage ( SYN_IE(UVar) ) import Maybes ( maybeToBool ) import Util ( isIn, panic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} %************************************************************************ @@ -95,10 +103,10 @@ data SimpleUnfolding noUnfolding = NoUnfolding -mkUnfolding inline_me expr +mkUnfolding inline_prag expr = let -- strictness mangling (depends on there being no CSE) - ufg = calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr + ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr occ = occurAnalyseGlobalExpr expr cuf = CoreUnfolding (SimpleUnfolding (mkFormSummary expr) ufg occ) @@ -124,23 +132,29 @@ data UnfoldingGuidance | UnfoldIfGoodArgs Int -- if "m" type args Int -- and "n" value args + [Int] -- Discount if the argument is evaluated. -- (i.e., a simplification will definitely -- be possible). One elt of the list per *value* arg. + Int -- The "size" of the unfolding; to be elaborated -- later. ToDo + + Int -- Scrutinee discount: the discount to substract if the thing is in + -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) \end{code} \begin{code} instance Outputable UnfoldingGuidance where - ppr sty UnfoldAlways = ppPStr SLIT("_ALWAYS_") --- ppr sty EssentialUnfolding = ppPStr SLIT("_ESSENTIAL_") -- shouldn't appear in an iface - ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppPStr SLIT("_IF_ARGS_"), ppInt t, ppInt v, + ppr sty UnfoldAlways = ptext SLIT("_ALWAYS_") + ppr sty (UnfoldIfGoodArgs t v cs size discount) + = hsep [ptext SLIT("_IF_ARGS_"), int t, int v, if null cs -- always print *something* - then ppChar 'X' - else ppBesides (map (ppStr . show) cs), - ppInt size ] + then char 'X' + else hcat (map (text . show) cs), + int size, + int discount ] \end{code} @@ -159,10 +173,10 @@ data FormSummary | OtherForm -- Anything else instance Outputable FormSummary where - ppr sty VarForm = ppPStr SLIT("Var") - ppr sty ValueForm = ppPStr SLIT("Value") - ppr sty BottomForm = ppPStr SLIT("Bot") - ppr sty OtherForm = ppPStr SLIT("Other") + ppr sty VarForm = ptext SLIT("Var") + ppr sty ValueForm = ptext SLIT("Value") + ppr sty BottomForm = ptext SLIT("Bot") + ppr sty OtherForm = ptext SLIT("Other") mkFormSummary ::GenCoreExpr bndr Id tyvar uvar -> FormSummary @@ -174,6 +188,9 @@ mkFormSummary expr go n (Prim _ _) = OtherForm go n (SCC _ e) = go n e go n (Coerce _ _ e) = go n e + + go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g) + -- should be treated as a value go n (Let _ e) = OtherForm go n (Case _ _) = OtherForm @@ -200,6 +217,15 @@ whnfOrBottom e = case mkFormSummary e of OtherForm -> False \end{code} +@exprIsTrivial@ is true of expressions we are unconditionally happy to duplicate; +simple variables and constants, and type applications. + +\begin{code} +exprIsTrivial (Var v) = True +exprIsTrivial (Lit lit) = not (isNoRepLit lit) +exprIsTrivial (App e (TyArg _)) = exprIsTrivial e +exprIsTrivial other = False +\end{code} \begin{code} exprSmallEnoughToDup (Con _ _) = True -- Could check # of args @@ -208,24 +234,12 @@ exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit) exprSmallEnoughToDup expr = case (collectArgs expr) of { (fun, _, _, vargs) -> case fun of - Var v | length vargs == 0 -> True + Var v | length vargs <= 4 -> True _ -> False } -{- LATER: -WAS: MORE CLEVER: -exprSmallEnoughToDup expr -- for now, just: applied to - = case (collectArgs expr) of { (fun, _, _, vargs) -> - case fun of - Var v -> v /= buildId - && v /= augmentId - && length vargs <= 6 -- or 10 or 1 or 4 or anything smallish. - _ -> False - } --} \end{code} -Question (ADR): What is the above used for? Is a _ccall_ really small -enough? + %************************************************************************ %* * @@ -235,25 +249,28 @@ enough? \begin{code} calcUnfoldingGuidance - :: Bool -- True <=> there's an INLINE pragma on this thing + :: PragmaInfo -- INLINE pragma stuff -> Int -- bomb out if size gets bigger than this -> CoreExpr -- expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so +calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so +calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so +calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa... -calcUnfoldingGuidance False bOMB_OUT_SIZE expr +calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr = case collectBinders expr of { (use_binders, ty_binders, val_binders, body) -> case (sizeExpr bOMB_OUT_SIZE val_binders body) of - Nothing -> UnfoldNever + TooBig -> UnfoldNever - Just (size, cased_args) + SizeIs size cased_args scrut_discount -> UnfoldIfGoodArgs (length ty_binders) (length val_binders) (map discount_for val_binders) - size + (I# size) + (I# scrut_discount) where discount_for b | is_data && b `is_elem` cased_args = tyConFamilySize tycon @@ -272,44 +289,23 @@ sizeExpr :: Int -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these -- get case'd -> CoreExpr - -> Maybe (Int, -- Size - [Id] -- Subset of args which are cased - ) + -> ExprSize -sizeExpr bOMB_OUT_SIZE args expr - - | data_or_prim fun --- We are very keen to inline literals, constructors, or primitives --- including their slightly-disguised forms as applications (the latter --- can show up in the bodies of things imported from interfaces). - = Just (0, []) - - | otherwise +sizeExpr (I# bOMB_OUT_SIZE) args expr = size_up expr where - (fun, _) = splitCoreApps expr - data_or_prim (Var v) = maybeToBool (isPrimitiveId_maybe v) || - isDataCon v - data_or_prim (Con _ _) = True - data_or_prim (Prim _ _) = True - data_or_prim (Lit _) = True - data_or_prim other = False - - size_up (Var v) = sizeZero - size_up (App fun arg) = size_up fun `addSize` size_up_arg arg `addSizeN` 1 - -- 1 for application node - - size_up (Lit lit) = if isNoRepLit lit - then sizeN uNFOLDING_NOREP_LIT_COST - else sizeZero - --- I don't understand this hack so I'm removing it! SLPJ Nov 96 --- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK ***** + size_up (Var v) = sizeZero + size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST + | otherwise = sizeZero size_up (SCC lbl body) = size_up body -- SCCs cost nothing size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing - size_up (Con con args) = sizeN (numValArgs args) + size_up (App fun arg) = size_up fun `addSize` size_up_arg arg + -- NB Zero cost for for type applications; + -- others cost 1 or more + + size_up (Con con args) = conSizeN (numValArgs args) -- We don't count 1 for the constructor because we're -- quite keen to get constructors into the open @@ -328,32 +324,34 @@ sizeExpr bOMB_OUT_SIZE args expr size_up body `addSizeN` length args size_up (Let (NonRec binder rhs) body) - = size_up rhs + = nukeScrutDiscount (size_up rhs) `addSize` size_up body - `addSizeN` - 1 size_up (Let (Rec pairs) body) - = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs] + = nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs]) `addSize` size_up body - `addSizeN` - length pairs size_up (Case scrut alts) - = size_up_scrut scrut + = nukeScrutDiscount (size_up scrut) + `addSize` + arg_discount scrut `addSize` size_up_alts (coreExprType scrut) alts -- We charge for the "case" itself in "size_up_alts" ------------ + -- In an application we charge 0 for type application + -- 1 for most anything else + -- N for norep_lits size_up_arg (LitArg lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST - size_up_arg other = sizeZero + size_up_arg (TyArg _) = sizeZero + size_up_arg other = sizeOne ------------ size_up_alts scrut_ty (AlgAlts alts deflt) - = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts + = (foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts) `addSizeN` alt_cost where @@ -370,8 +368,7 @@ sizeExpr bOMB_OUT_SIZE args expr alt_cost :: Int alt_cost - = --trace "CoreUnfold.getAppDataTyConExpandingDicts:2" $ - case (maybeAppDataTyConExpandingDicts scrut_ty) of + = case (maybeAppDataTyConExpandingDicts scrut_ty) of Nothing -> 1 Just (tc,_,_) -> tyConFamilySize tc @@ -382,47 +379,59 @@ sizeExpr bOMB_OUT_SIZE args expr size_prim_alt (lit,rhs) = size_up rhs ------------ - size_up_deflt NoDefault = sizeZero + size_up_deflt NoDefault = sizeZero size_up_deflt (BindDefault binder rhs) = size_up rhs ------------ - -- Scrutinees. There are two things going on here. - -- First, we want to record if we're case'ing an argument - -- Second, we want to charge nothing for the srutinee if it's just - -- a variable. That way wrapper-like things look cheap. - size_up_scrut (Var v) | v `is_elem` args = Just (0, [v]) - | otherwise = Just (0, []) - size_up_scrut other = size_up other + -- We want to record if we're case'ing an argument + arg_discount (Var v) | v `is_elem` args = scrutArg v + arg_discount other = sizeZero is_elem :: Id -> [Id] -> Bool is_elem = isIn "size_up_scrut" ------------ - sizeZero = Just (0, []) - sizeOne = Just (1, []) - sizeN n = Just (n, []) - - addSizeN Nothing _ = Nothing - addSizeN (Just (n, xs)) m - | tot < bOMB_OUT_SIZE = Just (tot, xs) - | otherwise = Nothing - where - tot = n+m + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument - addSize Nothing _ = Nothing - addSize _ Nothing = Nothing - addSize (Just (n, xs)) (Just (m, ys)) - | tot < bOMB_OUT_SIZE = Just (tot, xys) - | otherwise = Nothing + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) (I# m) + | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d + | otherwise = TooBig + where + n_tot = n +# m + + addSize TooBig _ = TooBig + addSize _ TooBig = TooBig + addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot + | otherwise = TooBig where - tot = n+m - xys = xs ++ ys + n_tot = n1 +# n2 + d_tot = d1 +# d2 + xys = xs ++ ys + -splitCoreApps e - = go e [] - where - go (App fun arg) args = go fun (arg:args) - go fun args = (fun,args) +\end{code} + +Code for manipulating sizes + +\begin{code} + +data ExprSize = TooBig + | SizeIs Int# -- Size found + [Id] -- Arguments cased herein + Int# -- Size to subtract if result is scrutinised + -- by a case expression + +sizeZero = SizeIs 0# [] 0# +sizeOne = SizeIs 1# [] 0# +sizeN (I# n) = SizeIs n [] 0# +conSizeN (I# n) = SizeIs n [] n +scrutArg v = SizeIs 0# [v] 0# + +nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0# +nukeScrutDiscount TooBig = TooBig \end{code} %************************************************************************ @@ -437,7 +446,8 @@ purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' a single integer. (3)~An ``argument info'' vector. For this, what we have at the moment is a Boolean per argument position that says, ``I will look with great favour on an explicit constructor in this -position.'' +position.'' (4)~The ``discount'' to subtract if the expression +is being scrutinised. Assuming we have enough type- and value arguments (if not, we give up immediately), then we see if the ``discounted size'' is below some @@ -446,25 +456,44 @@ position where we're looking for a constructor AND WE HAVE ONE in our hands, we get a (again, semi-arbitrary) discount [proportion to the number of constructors in the type being scrutinized]. +If we're in the context of a scrutinee ( \tr{(case of A .. -> ...;.. )}) +and the expression in question will evaluate to a constructor, we use +the computed discount size *for the result only* rather than +computing the argument discounts. Since we know the result of +the expression is going to be taken apart, discounting its size +is more accurate (see @sizeExpr@ above for how this discount size +is computed). + \begin{code} smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments + -> Bool -- Result is scrutinised -> UnfoldingGuidance -> Bool -- True => unfold it -smallEnoughToInline _ UnfoldAlways = True -smallEnoughToInline _ UnfoldNever = False -smallEnoughToInline arg_is_evald_s - (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size) +smallEnoughToInline _ _ UnfoldAlways = True +smallEnoughToInline _ _ UnfoldNever = False +smallEnoughToInline arg_is_evald_s result_is_scruted + (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount) = enough_args n_vals_wanted arg_is_evald_s && discounted_size <= opt_UnfoldingUseThreshold where + + enough_args n [] | n > 0 = False -- A function with no value args => don't unfold + enough_args _ _ = True -- Otherwise it's ok to try + +{- OLD: require saturated args enough_args 0 evals = True enough_args n [] = False enough_args n (e:es) = enough_args (n-1) es -- NB: don't take the length of arg_is_evald_s because when -- called from couldBeSmallEnoughToInline it is infinite! +-} + + discounted_size = size - args_discount - result_discount - discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s) + args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s) + result_discount | result_is_scruted = scrut_discount + | otherwise = 0 arg_discount no_of_constrs is_evald | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount @@ -476,11 +505,12 @@ use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. \begin{code} +--UNUSED? couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool -couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance +couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool -certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance +certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance \end{code} Predicates diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 7211966..c1388e3 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -38,16 +38,17 @@ import Maybes ( catMaybes, maybeToBool ) import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) -import Pretty ( ppAboves, ppStr ) -import PrelVals ( augmentId, buildId ) +import Pretty ( vcat, text ) import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( noSrcLoc ) import TyVar ( cloneTyVar, - isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv) + isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv), + SYN_IE(TyVar) ) import Type ( mkFunTy, mkForAllTy, mkForAllUsageTy, mkTyVarTy, getFunTyExpandingDicts_maybe, applyTy, isPrimType, - splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy + splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy, + SYN_IE(Type) ) import TysWiredIn ( trueDataCon, falseDataCon ) import UniqSupply ( initUs, returnUs, thenUs, @@ -85,8 +86,8 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point! -- a Prim is of a PrimOp coreExprType (Con con args) = --- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi, --- ppr PprDebug con_ty, ppSemi, +-- pprTrace "appTyArgs" (hsep [ppr PprDebug con, semi, +-- ppr PprDebug con_ty, semi, -- ppr PprDebug args]) $ applyTypeToArgs con_ty args where @@ -105,7 +106,7 @@ coreExprType (Lam (UsageBinder uvar) expr) coreExprType (App expr (TyArg ty)) = --- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $ +-- pprTrace "appTy1" (hsep [ppr PprDebug fun_ty, space, ppr PprDebug ty]) $ applyTy fun_ty ty where fun_ty = coreExprType expr @@ -122,7 +123,7 @@ coreExprType (App expr val_arg) Just (_, result_ty) -> result_ty #ifdef DEBUG Nothing -> pprPanic "coreExprType:\n" - (ppAboves [ppr PprDebug fun_ty, + (vcat [ppr PprDebug fun_ty, ppr PprShowAll (App expr val_arg)]) #endif \end{code} @@ -372,7 +373,7 @@ maybeErrorApp -- *pretend* that the result ty won't be -- primitive -- somebody later must -- ensure this. - -> Maybe (GenCoreExpr a Id TyVar UVar) + -> Maybe (GenCoreExpr b Id TyVar UVar) maybeErrorApp expr result_ty_maybe = case (collectArgs expr) of diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 6a83c06..d2a0588 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -28,14 +28,14 @@ import CoreSyn import Id ( idType, getIdArity, isBottomingId, emptyIdSet, unitIdSet, mkIdSet, elementOfIdSet, minusIdSet, unionManyIdSets, - SYN_IE(IdSet) + SYN_IE(IdSet), SYN_IE(Id) ) import IdInfo ( ArityInfo(..) ) import PrimOp ( PrimOp(..) ) -import Type ( tyVarsOfType ) +import Type ( tyVarsOfType, SYN_IE(Type) ) import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, intersectTyVarSets, - SYN_IE(TyVarSet) + SYN_IE(TyVarSet), SYN_IE(TyVar) ) import UniqSet ( unionUniqSets ) import Usage ( SYN_IE(UVar) ) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 9ee12f3..e0dcb03 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -28,8 +28,9 @@ IMP_Ubiq(){-uitous-} import CoreSyn import CostCentre ( showCostCentre ) import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, SYN_IE(DataCon), GenId{-instances-} - ) + nullIdEnv, SYN_IE(DataCon), GenId{-instances-}, + SYN_IE(Id) + ) import IdInfo ( ppIdInfo, StrictnessInfo(..) ) import Literal ( Literal{-instances-} ) import Name ( OccName, parenInCode ) @@ -57,7 +58,7 @@ function for ``major'' val_bdrs (those next to equal signs :-), usually be called through some intermediary. The binder/occ printers take the default ``homogenized'' (see -@PprEnv@...) @Pretty@ and the binder/occ. They can either use the +@PprEnv@...) @Doc@ and the binder/occ. They can either use the homogenized one, or they can ignore it completely. In other words, the things passed in act as ``hooks'', getting the last word on how to print something. @@ -65,7 +66,7 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code} -pprCoreBinding :: PprStyle -> CoreBinding -> Pretty +pprCoreBinding :: PprStyle -> CoreBinding -> Doc pprGenCoreBinding :: (Eq tyvar, Outputable tyvar, @@ -73,11 +74,11 @@ pprGenCoreBinding Outputable bndr, Outputable occ) => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees + -> (bndr -> Doc) -- to print "major" val_bdrs + -> (bndr -> Doc) -- to print "minor" val_bdrs + -> (occ -> Doc) -- to print bindees -> GenCoreBinding bndr occ tyvar uvar - -> Pretty + -> Doc pprGenCoreBinding sty pbdr1 pbdr2 pocc bind = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind @@ -87,7 +88,7 @@ init_ppr_env sty tvbndr pbdr1 pbdr2 pocc (Just (ppr sty)) -- literals (Just ppr_con) -- data cons (Just ppr_prim) -- primops - (Just (\ cc -> ppStr (showCostCentre sty True cc))) + (Just (\ cc -> text (showCostCentre sty True cc))) (Just tvbndr) -- tyvar binders (Just (ppr sty)) -- tyvar occs (Just (ppr sty)) -- usage vars @@ -107,38 +108,38 @@ init_ppr_env sty tvbndr pbdr1 pbdr2 pocc -- to distinguish them from ordinary applications. But not when -- printing for interfaces, where they are treated as ordinary applications ppr_con con | ifaceStyle sty = ppr sty con - | otherwise = ppr sty con `ppBeside` ppChar '!' + | otherwise = ppr sty con <> char '!' -} -- We add a "!" to distinguish Primitive applications from ordinary applications. -- But not when printing for interfaces, where they are treated -- as ordinary applications ppr_prim prim | ifaceStyle sty = ppr sty prim - | otherwise = ppr sty prim `ppBeside` ppChar '!' + | otherwise = ppr sty prim <> char '!' -------------- pprCoreBinding sty (NonRec binder expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + = hang (hsep [pprBigCoreBinder sty binder, equals]) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) pprCoreBinding sty (Rec binds) - = ppAboves [ifPprDebug sty (ppPStr SLIT("{- plain Rec -}")), - ppAboves (map ppr_bind binds), - ifPprDebug sty (ppPStr SLIT("{- end plain Rec -}"))] + = vcat [ptext SLIT("Rec {"), + vcat (map ppr_bind binds), + ptext SLIT("end Rec }")] where ppr_bind (binder, expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + = hang (hsep [pprBigCoreBinder sty binder, equals]) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) \end{code} \begin{code} pprCoreExpr :: PprStyle - -> (Id -> Pretty) -- to print "major" val_bdrs - -> (Id -> Pretty) -- to print "minor" val_bdrs - -> (Id -> Pretty) -- to print bindees + -> (Id -> Doc) -- to print "major" val_bdrs + -> (Id -> Doc) -- to print "minor" val_bdrs + -> (Id -> Doc) -- to print bindees -> CoreExpr - -> Pretty + -> Doc pprCoreExpr = pprGenCoreExpr pprGenCoreExpr, pprParendCoreExpr @@ -147,11 +148,11 @@ pprGenCoreExpr, pprParendCoreExpr Outputable bndr, Outputable occ) => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees + -> (bndr -> Doc) -- to print "major" val_bdrs + -> (bndr -> Doc) -- to print "minor" val_bdrs + -> (occ -> Doc) -- to print bindees -> GenCoreExpr bndr occ tyvar uvar - -> Pretty + -> Doc pprGenCoreExpr sty pbdr1 pbdr2 pocc expr = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr @@ -162,12 +163,12 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr = case expr of Var _ -> id -- leave unchanged Lit _ -> id - _ -> ppParens -- wraps in parens + _ -> parens -- wraps in parens in parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) -- Printer for unfoldings in interfaces -pprIfaceUnfolding :: CoreExpr -> Pretty +pprIfaceUnfolding :: CoreExpr -> Doc pprIfaceUnfolding = ppr_expr env where env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) @@ -197,34 +198,39 @@ instance Eq uvar, Outputable uvar) => Outputable (GenCoreBinding bndr occ tyvar uvar) where - ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind + ppr sty bind = pprQuote sty $ \sty -> + pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreExpr bndr occ tyvar uvar) where - ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr + ppr sty expr = pprQuote sty $ \sty -> + pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr instance (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreArg occ tyvar uvar) where - ppr sty arg = ppr_core_arg sty (ppr sty) arg + ppr sty arg = pprQuote sty $ \sty -> + ppr_core_arg sty (ppr sty) arg instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where - ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts + ppr sty alts = pprQuote sty $ \sty -> + ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where - ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt + ppr sty deflt = pprQuote sty $ \sty -> + ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt \end{code} %************************************************************************ @@ -235,15 +241,15 @@ instance \begin{code} ppr_bind pe (NonRec val_bdr expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) + = hang (hsep [pMajBndr pe val_bdr, equals]) 4 (ppr_expr pe expr) ppr_bind pe (Rec binds) - = ppAboves (map ppr_pair binds) + = vcat (map ppr_pair binds) where ppr_pair (val_bdr, expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe expr `ppBeside` ppSemi) + = hang (hsep [pMajBndr pe val_bdr, equals]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} @@ -253,7 +259,7 @@ ppr_parend_expr pe expr = case expr of Var _ -> id -- leave unchanged Lit _ -> id - _ -> ppParens -- wraps in parens + _ -> parens -- wraps in parens in parenify (ppr_expr pe expr) \end{code} @@ -263,25 +269,25 @@ ppr_expr pe (Var name) = pOcc pe name ppr_expr pe (Lit lit) = pLit pe lit ppr_expr pe (Con con args) - = ppHang (pCon pe con) - 4 (ppCurlies $ ppSep (map (ppr_arg pe) args)) + = hang (pCon pe con) + 4 (braces $ sep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) - = ppHang (pPrim pe prim) - 4 (ppSep (map (ppr_arg pe) args)) + = hang (pPrim pe prim) + 4 (sep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) = let (uvars, tyvars, vars, body) = collectBinders expr in - ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars, + hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars, pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, pp_vars SLIT("\\") (pMajBndr pe) vars]) 4 (ppr_expr pe body) where - pp_vars lam pp [] = ppNil + pp_vars lam pp [] = empty pp_vars lam pp vs - = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppPStr SLIT("->")] + = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")] ppr_expr pe expr@(App fun arg) = let @@ -289,7 +295,7 @@ ppr_expr pe expr@(App fun arg) go (App fun arg) args_so_far = go fun (arg:args_so_far) go fun args_so_far = (fun, args_so_far) in - ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args)) + hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args)) ppr_expr pe (Case expr alts) | only_one_alt alts @@ -297,12 +303,12 @@ ppr_expr pe (Case expr alts) -- and no indent; all sane persons agree with him. = let - ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow - ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) ppr_arrow - ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) ppr_arrow + ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) - = ppCat [pCon pe con, - ppInterleave ppSP (map (pMinBndr pe) params), + = hsep [pCon pe con, + hsep (map (pMinBndr pe) params), ppr_arrow] ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr @@ -311,58 +317,58 @@ ppr_expr pe (Case expr alts) ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr - ppr_arrow = ppPStr SLIT(" ->") + ppr_arrow = ptext SLIT(" ->") in - ppSep - [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts], - ppBeside (ppr_rhs alts) (ppStr ";}")] + sep + [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts], + (<>) (ppr_rhs alts) (text ";}")] | otherwise -- default "case" printing - = ppSep - [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppPStr SLIT("of {")], - ppNest 2 (ppr_alts pe alts), - ppStr "}"] + = sep + [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")], + nest 2 (ppr_alts pe alts), + text "}"] where pp_keyword = case alts of - AlgAlts _ _ -> ppPStr SLIT("case") - PrimAlts _ _ -> ppPStr SLIT("case#") + AlgAlts _ _ -> ptext SLIT("case") + PrimAlts _ _ -> ptext SLIT("case#") -- special cases: let ... in let ... -- ("disgusting" SLPJ) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = ppAboves [ - ppCat [ppPStr SLIT("let {"), pMajBndr pe val_bdr, ppEquals], - ppNest 2 (ppr_expr pe rhs), - ppPStr SLIT("} in"), + = vcat [ + hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals], + nest 2 (ppr_expr pe rhs), + ptext SLIT("} in"), ppr_expr pe body ] ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = ppAbove - (ppHang (ppPStr SLIT("let {")) - 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) + = ($$) + (hang (ptext SLIT("let {")) + 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals]) 4 (ppr_expr pe rhs), - ppPStr SLIT("} in")])) + ptext SLIT("} in")])) (ppr_expr pe expr) -- general case (recursive case, too) ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppPStr keyword) 2 (ppr_bind pe bind), - ppHang (ppPStr SLIT("} in ")) 2 (ppr_expr pe expr)] + = sep [hang (ptext keyword) 2 (ppr_bind pe bind), + hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)] where keyword = case bind of - Rec _ -> SLIT("letrec {") + Rec _ -> SLIT("_letrec_ {") NonRec _ _ -> SLIT("let {") ppr_expr pe (SCC cc expr) - = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], + = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc], ppr_parend_expr pe expr ] ppr_expr pe (Coerce c ty expr) - = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr] + = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = ppBeside (ppPStr SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppPStr SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) only_one_alt (AlgAlts [] (BindDefault _ _)) = True only_one_alt (AlgAlts (_:[]) NoDefault) = True @@ -373,41 +379,41 @@ only_one_alt _ = False \begin{code} ppr_alts pe (AlgAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] + = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] where - ppr_arrow = ppPStr SLIT("->") + ppr_arrow = ptext SLIT("->") ppr_alt (con, params, expr) - = ppHang (if isTupleCon con then - ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), - ppr_arrow] + = hang (if isTupleCon con then + hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))), + ppr_arrow] else - ppCat [pCon pe con, - ppInterleave ppSP (map (pMinBndr pe) params), + hsep [pCon pe con, + hsep (map (pMinBndr pe) params), ppr_arrow] ) - 4 (ppr_expr pe expr `ppBeside` ppSemi) + 4 (ppr_expr pe expr <> semi) ppr_alts pe (PrimAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] + = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (lit, expr) - = ppHang (ppCat [pLit pe lit, ppPStr SLIT("->")]) - 4 (ppr_expr pe expr `ppBeside` ppSemi) + = hang (hsep [pLit pe lit, ptext SLIT("->")]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} -ppr_default pe NoDefault = ppNil +ppr_default pe NoDefault = empty ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pMinBndr pe val_bdr, ppPStr SLIT("->")]) - 4 (ppr_expr pe expr `ppBeside` ppSemi) + = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = ppPStr SLIT("_@_ ") `ppBeside` pTy pe ty +ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} @@ -416,30 +422,30 @@ and @pprCoreExpr@ functions. \begin{code} pprBigCoreBinder sty binder - = ppAboves [sig, pragmas, ppr sty binder] + = vcat [sig, pragmas, ppr sty binder] where sig = ifnotPprShowAll sty ( - ppHang (ppCat [ppr sty binder, ppDcolon]) + hang (hsep [ppr sty binder, ppDcolon]) 4 (ppr sty (idType binder))) pragmas = ifnotPprForUser sty (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder)) pprBabyCoreBinder sty binder - = ppCat [ppr sty binder, pp_strictness] + = hsep [ppr sty binder, pp_strictness] where pp_strictness = case (getIdStrictness binder) of - NoStrictnessInfo -> ppNil - BottomGuaranteed -> ppPStr SLIT("{- _!_ -}") + NoStrictnessInfo -> empty + BottomGuaranteed -> ptext SLIT("{- _!_ -}") StrictnessInfo xx _ -> panic "PprCore:pp_strictness:StrictnessInfo:ToDo" - -- ppStr ("{- " ++ (showList xx "") ++ " -}") + -- text ("{- " ++ (showList xx "") ++ " -}") pprTypedCoreBinder sty binder - = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)] + = hcat [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)] -ppDcolon = ppPStr SLIT(" :: ") +ppDcolon = ptext SLIT(" :: ") -- The space before the :: is important; it helps the lexer -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 40e3bcc..9b4bfc0 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -6,18 +6,25 @@ \begin{code} #include "HsVersions.h" -module Desugar ( deSugar, DsMatchContext, pprDsWarnings, - DsWarnFlavour -- removed when compiling with 1.4 +module Desugar ( deSugar, pprDsWarnings +#if __GLASGOW_HASKELL__ < 200 + , DsMatchContext + , DsWarnFlavour -- fluff needed for closure, + -- removed when compiling with 1.4 +#endif ) where IMP_Ubiq(){-uitous-} -import HsSyn ( HsBinds, HsExpr ) -import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) +import HsSyn ( HsBinds, HsExpr, MonoBinds, + SYN_IE(RecFlag), nonRecursive + ) +import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) + ) import CoreSyn import Name ( isExported ) import DsMonad -import DsBinds ( dsBinds, dsInstBinds ) +import DsBinds ( dsBinds, dsMonoBinds ) import DsUtils import Bag ( unionBags ) @@ -27,9 +34,10 @@ import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) -import Id ( nullIdEnv, mkIdEnv, idType, SYN_IE(DictVar), GenId ) +import Id ( nullIdEnv, mkIdEnv, idType, + SYN_IE(DictVar), GenId, SYN_IE(Id) ) import PprStyle ( PprStyle(..) ) -import UniqSupply ( splitUniqSupply ) +import UniqSupply ( splitUniqSupply, UniqSupply ) \end{code} The only trick here is to get the @DsMonad@ stuff off to a good @@ -43,13 +51,13 @@ deSugar :: UniqSupply -- name supply TypecheckedHsBinds, -- bindings; see "tcModule" (which produces TypecheckedHsBinds, -- them) TypecheckedHsBinds, - [(Id, TypecheckedHsExpr)]) + TypecheckedHsBinds) -- ToDo: handling of const_inst thingies is certainly WRONG *************************** -> ([CoreBinding], -- output DsWarnings) -- Shadowing complaints -deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) +deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_binds) = let (us0, us0a) = splitUniqSupply us (us1, us1a) = splitUniqSupply us0a @@ -63,25 +71,24 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst Just xx -> _PK_ xx Nothing -> mod_name -- default: module name - ((core_const_prs, consts_pairs), shadows1) - = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) - - consts_env = mkIdEnv consts_pairs + (core_const_binds, shadows1) + = initDs us0 nullIdEnv mod_name (dsBinds const_inst_binds) + core_const_prs = pairsFromCoreBinds core_const_binds (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds clas_binds) + = initDs us1 nullIdEnv mod_name (dsBinds clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds inst_binds) + = initDs us2 nullIdEnv mod_name (dsBinds inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds val_binds) + = initDs us3 nullIdEnv mod_name (dsBinds val_binds) core_val_pairs = map (addAutoScc module_and_group) (pairsFromCoreBinds core_val_binds) (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds recsel_binds) + = initDs us4 nullIdEnv mod_name (dsBinds recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds diff --git a/ghc/compiler/deSugar/DsBinds.hi-boot b/ghc/compiler/deSugar/DsBinds.hi-boot new file mode 100644 index 0000000..b2b82c4 --- /dev/null +++ b/ghc/compiler/deSugar/DsBinds.hi-boot @@ -0,0 +1,5 @@ +_interface_ DsBinds 1 +_exports_ +DsBinds dsBinds; +_declarations_ +1 dsBinds _:_ TcHsSyn.TypecheckedHsBinds -> DsMonad.DsM [CoreSyn.CoreBinding] ;; diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index af09307..6a1bc06 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -10,20 +10,18 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} #include "HsVersions.h" -module DsBinds ( dsBinds, dsInstBinds ) where +module DsBinds ( dsBinds, dsMonoBinds ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop import HsSyn -- lots of things - hiding ( collectBinders{-also in CoreSyn-} ) import CoreSyn -- lots of things +import CoreUtils ( coreExprType ) import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr), - SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds), + SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat) ) -import DsHsSyn ( collectTypedBinders, collectTypedPatBinders ) - import DsMonad import DsGRHSs ( dsGuarded ) import DsUtils @@ -32,21 +30,16 @@ import Match ( matchWrapper ) import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals ) import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) -import Id ( idType, SYN_IE(DictVar), GenId ) +import Id ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) ) import ListSetOps ( minusList, intersectLists ) import Name ( isExported ) import PprType ( GenType ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppShow ) -import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy, - tyVarsOfType, tyVarsOfTypes, isDictTy +import Type ( mkTyVarTy, isDictTy, instantiateTy ) import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) +import TysPrim ( voidTy ) import Util ( isIn, panic{-, pprTrace ToDo:rm-} ) ---import PprCore--ToDo:rm ---import PprType ( GenTyVar ) --ToDo:rm ---import Usage--ToDo:rm ---import Unique--ToDo:rm \end{code} %************************************************************************ @@ -61,355 +54,17 @@ the caller wraps the bindings round an expression. \begin{code} dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] -\end{code} - -All ``real'' bindings are expressed in terms of the -@AbsBinds@ construct, which is a massively-complicated ``shorthand'', -and its desugaring is the subject of section~9.1 in the static -semantics paper. - -(ToDo) For: -\begin{verbatim} -AbsBinds [a1, ... ,aj] -- type variables - [d1, ... ,dk] -- dict variables - [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...) - [db1=..., ..., dbn=...] -- dict binds - [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i -\end{verbatim} -we want to make, in the general case (non-Fozzie translation): -\begin{verbatim} - -- tupler-upper: - tup a1...aj d1...dk = - let in - let(rec) in (vb1,...,vbm) -- NB: == ... in (l1,...,lm) - - -- a bunch of selectors: - g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1 - ... - gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm -\end{verbatim} -But there are lots of special cases. - - -%============================================== -\subsubsection{Structure cases} -%============================================== - -\begin{code} -dsBinds (BindWith _ _) = panic "dsBinds:BindWith" -dsBinds EmptyBinds = returnDs [] -dsBinds (SingleBind bind) = dsBind [] [] id [] bind - -dsBinds (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds binds_1) (dsBinds binds_2) -\end{code} - - -%============================================== -\subsubsection{AbsBind case: no overloading} -%============================================== - -Special case: no overloading. -\begin{verbatim} - x1 = e1 - x2 = e2 -\end{verbatim} -We abstract each wrt the type variables, giving -\begin{verbatim} - x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2] - x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2] -\end{verbatim} -There are some complications. - -(i) The @val_binds@ might mention variable not in @local_global_prs@. -In this case we need to make up new polymorphic versions of them. - -(ii) Exactly the same applies to any @inst_binds@ which may be -present. However, here we expect that mostly they will be simple constant -definitions, which don't mention the type variables at all, so making them -polymorphic is really overkill. @dsInstBinds@ deals with this case. - -\begin{code} -dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) - = mapDs mk_poly_private_binder private_binders - `thenDs` \ poly_private_binders -> - let - full_local_global_prs = (private_binders `zip` poly_private_binders) - ++ local_global_prs - in - listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app -> - returnDs (local, app) - | (local,global) <- full_local_global_prs - ] `thenDs` \ env -> --- pprTrace "AbsBinds1:" (ppr PprDebug env) $ +dsBinds EmptyBinds = returnDs [] +dsBinds (ThenBinds binds_1 binds_2) = andDs (++) (dsBinds binds_1) (dsBinds binds_2) - extendEnvDs env ( - - dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> - extendEnvDs inst_env ( - - dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds - )) - where - -- "private_binders" is the list of binders in val_binds - -- which don't appear in the local_global_prs list - -- These only really show up in stuff produced from compiling - -- class and instance declarations. - -- We need to add suitable polymorphic versions of them to the - -- local_global_prs. - private_binders = binders `minusList` [local | (local,_) <- local_global_prs] - binders = collectTypedBinders val_binds - mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id)) - - tyvar_tys = mkTyVarTys tyvars -\end{code} - - -%============================================== -\subsubsection{AbsBind case: overloading} -%============================================== - -If there is overloading we go for the general case. - -We want the global identifiers to be abstracted wrt all types and -dictionaries; and the local identifiers wrt the non-overloaded types. -That is, we try to avoid global scoping of type abstraction. Example - - f :: Eq a => a -> [(a,b)] -> b - f = ...f... - -Here, f is fully polymorphic in b. So we generate - - f ab d = let ...dict defns... - in - letrec f' b = ...(f' b)... - in f' b - -*Notice* that we don't clone type variables, and *do* make use of -shadowing. It is possible to do cloning, but it makes the code quite -a bit more complicated, and the simplifier will clone it all anyway. - -Why bother with this gloss? Because it makes it more likely that -the defn of f' can get floated out, notably if f gets specialised -to a particular type for a. - -\begin{code} -dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) - = -- If there is any non-overloaded polymorphism, make new locals with - -- appropriate polymorphism - (if null non_overloaded_tyvars - then - -- No non-overloaded polymorphism, so stay with current envt - returnDs (id, [], []) - else - -- Some local, non-overloaded polymorphism - cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars -> - - mapDs mk_binder binders `thenDs` \ new_binders -> - let - old_new_pairs = binders `zip` new_binders - in - - listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app -> - returnDs (old, app) - | (old,new) <- old_new_pairs - ] `thenDs` \ extra_env -> - let - local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals] - is_elem = isIn "dsBinds" - in - returnDs (lookupId old_new_pairs, extra_env, local_binds) +dsBinds (MonoBind binds sigs is_rec) + = dsMonoBinds is_rec binds `thenDs` \ prs -> + returnDs (if is_rec then + [Rec prs] + else + [NonRec binder rhs | (binder,rhs) <- prs] ) - `thenDs` \ (binder_subst_fn, local_env, local_binds) -> - --- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $ - - extendEnvDs local_env ( - - dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) -> - - extendEnvDs inst_env ( - - dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds - )) `thenDs` \ core_binds -> - - let - tuple_rhs = mkCoLetsAny core_binds ( - mkCoLetsAny local_binds ( - mkTupleExpr locals )) - in - mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs -> - - returnDs (mk_result_bind core_bind_prs) - where - locals = [local | (local,global) <- local_global_prs] - non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars - - overloaded_tyvars = tyVarsOfTypes (map idType dicts) - non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars) - - binders = collectTypedBinders val_binds - mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id)) - - is_rec_bind = case val_binds of - RecBind _ -> True - NonRecBind _ -> False - - -- Recursion can still be needed if there are type signatures - mk_result_bind prs | is_rec_bind = [Rec prs] - | otherwise = [NonRec binder rhs | (binder,rhs) <- prs] -\end{code} - -@mkSatTyApp id tys@ constructs an expression whose value is (id tys). -However, sometimes id takes more type args than are in tys, and the -specialiser hates that, so we have to eta expand, to -@(/\ a b -> id tys a b)@. - -\begin{code} -mkSatTyApp :: Id -- Id to apply to the types - -> [Type] -- Types to apply it to - -> DsM CoreExpr - -mkSatTyApp id [] = returnDs (Var id) - -mkSatTyApp id tys - | null tvs - = returnDs ty_app -- Common case - | otherwise - = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars -> - returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars))) - where - (tvs, theta, tau_ty) = splitSigmaTy (idType id) - ty_app = mkTyApp (Var id) tys -\end{code} - -There are several places where we encounter ``inst binds,'' -@(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds -(a var to a var or literal), which we want to substitute away; so we -return both some desugared bindings {\em and} a substitution -environment for the subbed-away ones. - -These dictionary bindings are non-recursive, and ordered, so that -later ones may mention earlier ones, but not vice versa. - -\begin{code} -dsInstBinds :: [TyVar] -- Abstract wrt these - -> [(Id, TypecheckedHsExpr)] -- From AbsBinds - -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings - [(Id,CoreExpr)]) -- Trivial ones to be substituted away - -do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh) -prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto - -dsInstBinds tyvars [] = returnDs do_nothing - -dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs) - = dsExpr expr `thenDs` \ rhs -> - let -- Need to apply dsExpr to the variable in case it - -- has a substitution in the current environment - subst_item = (inst, rhs) - in - extendEnvDs [subst_item] ( - dsInstBinds tyvars bs - ) `thenDs` \ (binds, subst_env) -> - returnDs (binds, subst_item : subst_env) - -dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs) - = dsExpr expr `thenDs` \ core_lit -> - let - subst_item = (inst, core_lit) - in - extendEnvDs [subst_item] ( - dsInstBinds tyvars bs - ) `thenDs` \ (binds, subst_env) -> - returnDs (binds, subst_item : subst_env) - -dsInstBinds tyvars ((inst, expr) : bs) - | null abs_tyvars - = dsExpr expr `thenDs` \ core_expr -> - ds_dict_cc core_expr `thenDs` \ dict_expr -> - dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) -> - returnDs ((inst, dict_expr) : core_rest, subst_env) - - | otherwise - = -- Obscure case. - -- The inst mentions the type vars wrt which we are abstracting, - -- so we have to invent a new polymorphic version, and substitute - -- appropriately. - -- This can occur in, for example: - -- leftPoll :: [FeedBack a] -> FeedBack a - -- leftPoll xs = take poll xs - -- Here there is an instance of take at the type of elts of xs, - -- as well as the type of poll. - - dsExpr expr `thenDs` \ core_expr -> - ds_dict_cc core_expr `thenDs` \ dict_expr -> - newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id -> - let - subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys) - in - extendEnvDs [subst_item] ( - dsInstBinds tyvars bs - ) `thenDs` \ (core_rest, subst_env) -> - returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest, - subst_item : subst_env) - where - inst_ty = idType inst - abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars - abs_tys = mkTyVarTys abs_tyvars - poly_inst_ty = mkForAllTys abs_tyvars inst_ty - - ------------------------ - -- Wrap a desugared expression in `_scc_ "DICT" ' if - -- appropriate. Uses "inst"'s type. - - -- if profiling, wrap the dict in "_scc_ DICT ": - ds_dict_cc expr - | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs) - -- the latter is so that -unprof-auto-scc-all adds dict sccs - || not (isDictTy inst_ty) - = returnDs expr -- that's easy: do nothing - - | opt_CompilingGhcInternals - = returnDs (SCC prel_dicts_cc expr) - - | otherwise - = getModuleAndGroupDs `thenDs` \ (mod, grp) -> - - -- ToDo: do -dicts-all flag (mark dict things with individual CCs) - - returnDs (SCC (mkAllDictsCC mod grp False) expr) -\end{code} - -%************************************************************************ -%* * -\subsection[dsBind]{Desugaring a @Bind@} -%* * -%************************************************************************ - -Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that -some of the binders are of unboxed type. - -For an explanation of the first three args, see @dsMonoBinds@. - -\begin{code} -dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these - -> (Id -> Id) -- Binder substitution - -> [(Id,CoreExpr)] -- Inst bindings already dealt with - -> TypecheckedBind - -> DsM [CoreBinding] - -dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind - = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs] - -dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) - = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> - returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] - -dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) - = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> - returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] \end{code} @@ -419,138 +74,92 @@ dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) %* * %************************************************************************ -@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@. -In addition to desugaring pattern matching, @dsMonoBinds@ takes -a list of type variables and dicts, and adds abstractions for these -to the front of every binding. That requires that the -binders be altered too (their type has changed, -so @dsMonoBinds@ also takes a function which maps binders into binders. -This mapping gives the binder the correct new type. - -Remember, there's also a substitution in the monad which maps occurrences -of these binders into applications of the new binder to suitable type variables -and dictionaries. - \begin{code} -dsMonoBinds :: Bool -- True <=> recursive binding group - -> [TyVar] -> [DictVar] -- Abstract wrt these - -> (Id -> Id) -- Binder substitution - -> TypecheckedMonoBinds - -> DsM [(Id,CoreExpr)] -\end{code} +dsMonoBinds :: RecFlag -> TypecheckedMonoBinds -> DsM [(Id,CoreExpr)] +dsMonoBinds is_rec EmptyMonoBinds = returnDs [] +dsMonoBinds is_rec (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds is_rec binds_1) (dsMonoBinds is_rec binds_2) -%============================================== -\subsubsection{Structure cases} -%============================================== +dsMonoBinds is_rec (CoreMonoBind var core_expr) + = returnDs [(var, core_expr)] -\begin{code} -dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] - -dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) - (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) -\end{code} - - -%============================================== -\subsubsection{Simple base cases: function and variable bindings} -%============================================== +dsMonoBinds is_rec (VarMonoBind var expr) + = dsExpr expr `thenDs` \ core_expr -> -\begin{code} -dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) - = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] + -- Dictionary bindings are always VarMonoBinds, so + -- we only need do this here + addDictScc var core_expr `thenDs` \ core_expr' -> -dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) - = dsExpr expr `thenDs` \ core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] + returnDs [(var, core_expr')] -dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) +dsMonoBinds is_rec (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ - let - new_fun = binder_subst fun - error_string = "function " ++ showForErr fun - in matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - returnDs [(new_fun, - mkLam tyvars (dicts ++ args) body)] + returnDs [(fun, mkValLam args body)] + where + error_string = "function " ++ showForErr fun -dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) - = putSrcLocDs locn $ - dsGuarded grhss_and_binds `thenDs` \ body_expr -> - returnDs [(binder_subst v, mkLam tyvars dicts body_expr)] +dsMonoBinds is_rec (PatMonoBind pat grhss_and_binds locn) + = putSrcLocDs locn $ + dsGuarded grhss_and_binds `thenDs` \ body_expr -> + mkSelectorBinds pat body_expr + +dsMonoBinds is_rec (AbsBinds [] [] exports binds) -- Common special case + = dsMonoBinds is_rec binds `thenDs` \ prs -> + returnDs (prs ++ [(global, Var local) | (_, global, local) <- exports]) + +dsMonoBinds is_rec (AbsBinds all_tyvars dicts exports binds) + = dsMonoBinds is_rec binds `thenDs` \ core_prs -> + let + core_binds | is_rec = [Rec core_prs] + | otherwise = [NonRec b e | (b,e) <- core_prs] + + tup_expr = mkLam all_tyvars dicts $ + mkCoLetsAny core_binds $ + mkTupleExpr locals + locals = [local | (_, _, local) <- exports] + local_tys = map idType locals + in + newSysLocalDs (coreExprType tup_expr) `thenDs` \ tup_id -> + let + dict_args = map VarArg dicts + + mk_bind (tyvars, global, local) n -- locals !! n == local + = -- Need to make fresh locals to bind in the selector, because + -- some of the tyvars will be bound to voidTy + newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' -> + returnDs (global, mkLam tyvars dicts $ + mkTupleSelector locals' (locals' !! n) $ + mkValApp (mkTyApp (Var tup_id) ty_args) dict_args) + where + mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar + | otherwise = voidTy + ty_args = map mk_ty_arg all_tyvars + env = all_tyvars `zip` ty_args + in + zipWithDs mk_bind exports [0..] `thenDs` \ export_binds -> + returnDs ((tup_id, tup_expr) : export_binds) \end{code} -%============================================== -\subsubsection{The general base case} -%============================================== - -Now the general case of a pattern binding. The monomorphism restriction -should ensure that if there is a non-simple pattern binding in the -group, then there is no overloading involved, so the dictionaries should -be empty. (Simple pattern bindings were handled above.) -First, the paranoia check. +If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT ": \begin{code} -dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) - = panic "Non-empty dict list in for pattern binding" -\end{code} - -We handle three cases for the binding - pat = rhs - -\begin{description} -\item[pat has no binders.] -Then all this is dead code and we return an empty binding. - -\item[pat has exactly one binder, v.] -Then we can transform to: -\begin{verbatim} - v' = /\ tyvars -> case rhs of { pat -> v } -\end{verbatim} -where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}. - -\item[pat has more than one binder.] -Then we transform to: -\begin{verbatim} - t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) } +addDictScc var rhs + | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs) + -- the latter is so that -unprof-auto-scc-all adds dict sccs + || not (isDictTy (idType var)) + = returnDs rhs -- That's easy: do nothing - vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi } -\end{verbatim} -\end{description} + | opt_CompilingGhcInternals + = returnDs (SCC prel_dicts_cc rhs) -\begin{code} -dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) - = putSrcLocDs locn $ + | otherwise + = getModuleAndGroupDs `thenDs` \ (mod, grp) -> - dsGuarded grhss_and_binds `thenDs` \ body_expr -> + -- ToDo: do -dicts-all flag (mark dict things with individual CCs) + returnDs (SCC (mkAllDictsCC mod grp False) rhs) -{- KILLED by Sansom. 95/05 - -- make *sure* there are no primitive types in the pattern - if any_con_w_prim_arg pat then - error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t" - ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n" - ++ "(We apologise for not reporting this more `cleanly')\n" ) - - -- Check whether the pattern already is a simple tuple; if so, - -- we can just use the rhs directly - else --} --- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ - - mkSelectorBinds tyvars pat - [(binder, binder_subst binder) | binder <- pat_binders] - body_expr - where - pat_binders = collectTypedPatBinders pat - -- NB For a simple tuple pattern, these binders - -- will appear in the right order! +prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto \end{code} - -Wild-card patterns could be made acceptable here, but it involves some -extra work to benefit only rather unusual constructs like -\begin{verbatim} - let (_,a,b) = ... in ... -\end{verbatim} -Better to extend the whole thing for any irrefutable constructor, at least. diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index a50bdc4..3badf97 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -24,7 +24,7 @@ import Pretty import PrelVals ( packStringForCId ) import PrimOp ( PrimOp(..) ) import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon, - eqTy, maybeBoxedPrimType ) + eqTy, maybeBoxedPrimType, SYN_IE(Type) ) import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( getStatePairingConInfo, @@ -32,6 +32,10 @@ import TysWiredIn ( getStatePairingConInfo, stringTy ) import Util ( pprPanic, pprError, panic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif + \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -172,7 +176,7 @@ unboxArg arg can't_see_datacons_error thing ty = pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ " - (ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty]) + (hcat [text thing, text "; type: ", ppr PprForUser ty]) \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot b/ghc/compiler/deSugar/DsExpr.hi-boot new file mode 100644 index 0000000..5672e4c --- /dev/null +++ b/ghc/compiler/deSugar/DsExpr.hi-boot @@ -0,0 +1,5 @@ +_interface_ DsExpr 1 +_exports_ +DsExpr dsExpr; +_declarations_ +1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;; diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 96e870e..1c25806 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -26,7 +26,7 @@ import DsMonad import DsCCall ( dsCCall ) import DsHsSyn ( outPatType ) import DsListComp ( dsListComp ) -import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, +import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, mkTupleExpr, mkErrorAppDs, showForErr, EquationInfo, MatchResult, SYN_IE(DsCoreArg) ) @@ -38,18 +38,18 @@ import CostCentre ( mkUserCC ) import FieldLabel ( fieldLabelType, FieldLabel ) import Id ( idType, nullIdEnv, addOneToIdEnv, dataConArgTys, dataConFieldLabels, - recordSelectorFieldLabel + recordSelectorFieldLabel, SYN_IE(Id) ) import Literal ( mkMachInt, Literal(..) ) import Name ( Name{--O only-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType ) import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) -import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) +import Pretty ( Doc, hcat, ptext, text ) import TyCon ( isDataTyCon, isNewTyCon ) import Type ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy, - maybeBoxedPrimType, splitAppTy + maybeBoxedPrimType, splitAppTy, SYN_IE(Type) ) import TysPrim ( voidTy ) import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, @@ -60,6 +60,10 @@ import Usage ( SYN_IE(UVar) ) import Maybes ( maybeToBool ) import Util ( zipEqual, pprError, panic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif + mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... \end{code} @@ -150,7 +154,7 @@ dsExpr (HsLitOut (HsLitLit s) ty) -> (boxing_data_con, typePrimRep prim_ty) Nothing -> pprError "ERROR: ``literal-literal'' not a single-constructor type: " - (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty]) + (hcat [ptext s, text "; type: ", ppr PprDebug ty]) dsExpr (HsLitOut (HsInt i) ty) = returnDs (Lit (NoRepInteger i ty)) @@ -268,18 +272,25 @@ dsExpr (HsLet binds expr) returnDs ( mkCoLetsAny core_binds core_expr ) dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc) - | maybeToBool maybe_list_comp -- Special case for list comprehensions - = putSrcLocDs src_loc $ + | maybeToBool maybe_list_comp + = -- Special case for list comprehensions + putSrcLocDs src_loc $ dsListComp stmts elt_ty | otherwise = putSrcLocDs src_loc $ dsDo do_or_lc stmts return_id then_id zero_id result_ty where - maybe_list_comp = case maybeAppTyCon result_ty of - Just (tycon, [elt_ty]) | tycon == listTyCon - -> Just elt_ty - other -> Nothing + maybe_list_comp + = case (do_or_lc, maybeAppTyCon result_ty) of + (ListComp, Just (tycon, [elt_ty])) + | tycon == listTyCon + -> Just elt_ty + other -> Nothing + -- We need the ListComp form to use deListComp (rather than the "do" form) + -- because the "return" in a do block is a call to "PrelBase.return", and + -- not a ReturnStmt. Only the ListComp form has ReturnStmts + Just elt_ty = maybe_list_comp dsExpr (HsIf guard_expr then_expr else_expr src_loc) @@ -405,20 +416,20 @@ might do some argument-evaluation first; and may have to throw away some dictionaries. \begin{code} -dsExpr (RecordUpdOut record_expr dicts rbinds) +dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) = dsExpr record_expr `thenDs` \ record_expr' -> -- Desugar the rbinds, and generate let-bindings if -- necessary so that we don't lose sharing dsRbinds rbinds $ \ rbinds' -> let - record_ty = coreExprType record_expr' - (tycon, inst_tys, cons) = --trace "DsExpr.getAppDataTyConExpandingDicts" $ - getAppDataTyConExpandingDicts record_ty - cons_to_upd = filter has_all_fields cons + record_in_ty = coreExprType record_expr' + (tycon, in_inst_tys, cons) = getAppDataTyConExpandingDicts record_in_ty + (_, out_inst_tys, _) = getAppDataTyConExpandingDicts record_out_ty + cons_to_upd = filter has_all_fields cons -- initial_args are passed to every constructor - initial_args = map TyArg inst_tys ++ map VarArg dicts + initial_args = map TyArg out_inst_tys ++ map VarArg dicts mk_val_arg (field, arg_id) = case [arg | (f, arg) <- rbinds', @@ -428,7 +439,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) [] -> VarArg arg_id mk_alt con - = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids -> + = newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids -> let val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids) in @@ -438,8 +449,8 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) | length cons_to_upd == length cons = returnDs NoDefault | otherwise - = newSysLocalDs record_ty `thenDs` \ deflt_id -> - mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err -> + = newSysLocalDs record_in_ty `thenDs` \ deflt_id -> + mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err -> returnDs (BindDefault deflt_id err) in mapDs mk_alt cons_to_upd `thenDs` \ alts -> @@ -480,27 +491,15 @@ of length 0 or 1. \end{verbatim} \begin{code} dsExpr (SingleDict dict) -- just a local - = lookupEnvWithDefaultDs dict (Var dict) - -dsExpr (Dictionary dicts methods) - = -- hey, these things may have been substituted away... - zipWithDs lookupEnvWithDefaultDs - dicts_and_methods dicts_and_methods_exprs - `thenDs` \ core_d_and_ms -> - - (case num_of_d_and_ms of - 0 -> returnDs (Var voidId) + = lookupEnvDs dict `thenDs` \ dict' -> + returnDs (Var dict') - 1 -> returnDs (head core_d_and_ms) -- just a single Id +dsExpr (Dictionary [] []) -- Empty dictionary represented by void, + = returnDs (Var voidId) -- (not, as would happen if we took the next case, by ()) - _ -> -- tuple 'em up - mkConDs (tupleCon num_of_d_and_ms) - (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms) - ) - where - dicts_and_methods = dicts ++ methods - dicts_and_methods_exprs = map Var dicts_and_methods - num_of_d_and_ms = length dicts_and_methods +dsExpr (Dictionary dicts methods) + = mapDs lookupEnvDs (dicts ++ methods) `thenDs` \ d_and_ms' -> + returnDs (mkTupleExpr d_and_ms') dsExpr (ClassDictLam dicts methods expr) = dsExpr expr `thenDs` \ core_expr -> @@ -563,10 +562,8 @@ dsApp (OpApp e1 op _ e2) args dsApp op (VarArg core_e1 : VarArg core_e2 : args) dsApp (DictApp expr dicts) args - = -- now, those dicts may have been substituted away... - zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts) - `thenDs` \ core_dicts -> - dsApp expr (map VarArg core_dicts ++ args) + = mapDs lookupEnvDs dicts `thenDs` \ core_dicts -> + dsApp expr (map (VarArg . Var) core_dicts ++ args) dsApp (TyApp expr tys) args = dsApp expr (map TyArg tys ++ args) @@ -578,8 +575,8 @@ dsApp anything_else args mkAppDs core_expr args dsId v - = lookupEnvDs v `thenDs` \ maybe_expr -> - returnDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) + = lookupEnvDs v `thenDs` \ v' -> + returnDs (Var v') \end{code} \begin{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index c36e0bd..b6a1c90 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -12,21 +12,28 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop import HsSyn ( GRHSsAndBinds(..), GRHS(..), - HsExpr, HsBinds + HsExpr(..), HsBinds, Stmt(..), + HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedHsExpr) ) -import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny ) + SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt) + ) +import CoreSyn ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny ) import DsMonad import DsUtils -import CoreUtils ( mkCoreIfThenElse ) +#if __GLASGOW_HASKELL__ < 200 +import Id ( GenId ) +#endif +import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppShow ) import SrcLoc ( SrcLoc{-instance-} ) +import Type ( SYN_IE(Type) ) +import Unique ( Unique, otherwiseIdKey ) +import UniqFM ( Uniquable(..) ) import Util ( panic ) \end{code} @@ -88,13 +95,51 @@ dsGRHS ty kind pats (OtherwiseGRHS expr locn) dsGRHS ty kind pats (GRHS guard expr locn) = putSrcLocDs locn $ - dsExpr guard `thenDs` \ core_guard -> - dsExpr expr `thenDs` \ core_expr -> + dsExpr expr `thenDs` \ core_expr -> let - expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail + expr_fn = \ ignore -> core_expr in - returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn)) + matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn)) \end{code} + +%************************************************************************ +%* * +%* matchGuard : make a MatchResult from a guarded RHS * +%* * +%************************************************************************ + +\begin{code} +matchGuard :: [TypecheckedStmt] -- Guard + -> MatchResult -- What to do if the guard succeeds + -> DsM MatchResult + +matchGuard [] body_result = returnDs body_result + + -- Turn an "otherwise" guard is a no-op +matchGuard (GuardStmt (HsVar v) _ : stmts) body_result + | uniqueOf v == otherwiseIdKey + = matchGuard stmts body_result + +matchGuard (GuardStmt expr _ : stmts) body_result + = matchGuard stmts body_result `thenDs` \ (MatchResult _ ty body_fn cxt) -> + dsExpr expr `thenDs` \ core_expr -> + let + expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail + in + returnDs (MatchResult CanFail ty expr_fn cxt) + +matchGuard (LetStmt binds : stmts) body_result + = matchGuard stmts body_result `thenDs` \ match_result -> + dsBinds binds `thenDs` \ core_binds -> + returnDs (mkCoLetsMatchResult core_binds match_result) + +matchGuard (BindStmt pat rhs _ : stmts) body_result + = matchGuard stmts body_result `thenDs` \ match_result -> + dsExpr rhs `thenDs` \ core_rhs -> + newSysLocalDs (coreExprType core_rhs) `thenDs` \ scrut_var -> + match [scrut_var] [EqnInfo [pat] match_result] [] `thenDs` \ match_result' -> + returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result') +\end{code} diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 010d741..070b243 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -10,12 +10,13 @@ module DsHsSyn where IMP_Ubiq() -import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..), +import HsSyn ( OutPat(..), HsBinds(..), MonoBinds(..), Sig, HsExpr, GRHSsAndBinds, Match, HsLit ) -import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedBind), +import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMonoBinds) ) -import Id ( idType ) +import Id ( idType, SYN_IE(Id) ) +import Type ( SYN_IE(Type) ) import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) import Util ( panic ) \end{code} @@ -53,11 +54,6 @@ the same order as they appear in the tuple. collectTypedBinders and collectedTypedPatBinders are the exportees. \begin{code} -collectTypedBinders :: TypecheckedBind -> [Id] -collectTypedBinders EmptyBind = [] -collectTypedBinders (NonRecBind bs) = collectTypedMonoBinders bs -collectTypedBinders (RecBind bs) = collectTypedMonoBinders bs - collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id] collectTypedMonoBinders EmptyMonoBinds = [] collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat @@ -66,6 +62,8 @@ collectTypedMonoBinders (VarMonoBind v _) = [v] collectTypedMonoBinders (CoreMonoBind v _) = [v] collectTypedMonoBinders (AndMonoBinds bs1 bs2) = collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2 +collectTypedMonoBinders (AbsBinds _ _ exports _) + = [global | (_, global, local) <- exports] collectTypedPatBinders :: TypecheckedPat -> [Id] collectTypedPatBinders (VarPat var) = [var] diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index bec2c8a..2730867 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -21,8 +21,9 @@ import DsUtils import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( coreExprType, mkCoreIfThenElse ) +import Id ( SYN_IE(Id) ) import PrelVals ( mkBuild, foldrId ) -import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy ) +import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, SYN_IE(Type) ) import TysPrim ( alphaTy ) import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) import TyVar ( alphaTyVar ) diff --git a/ghc/compiler/deSugar/DsLoop.hs b/ghc/compiler/deSugar/DsLoop.hs new file mode 100644 index 0000000..c2d656c --- /dev/null +++ b/ghc/compiler/deSugar/DsLoop.hs @@ -0,0 +1,12 @@ +module DsLoop + ( + module Match, + module DsExpr, + module DsBinds + ) where + +import Match +import DsExpr +import DsBinds + + diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index c2034d7..a29cc5a 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -16,12 +16,11 @@ module DsMonad ( newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleAndGroupDs, - extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, + extendEnvDs, lookupEnvDs, SYN_IE(DsIdEnv), - lookupId, dsShadowWarn, dsIncompleteWarn, - DsWarnings(..), + SYN_IE(DsWarnings), DsMatchContext(..), DsMatchKind(..), pprDsWarnings, DsWarnFlavour -- Nuke with 1.4 @@ -29,23 +28,27 @@ module DsMonad ( IMP_Ubiq() -import Bag ( emptyBag, snocBag, bagToList ) +import Bag ( emptyBag, snocBag, bagToList, Bag ) import CmdLineOpts ( opt_SccGroup ) import CoreSyn ( SYN_IE(CoreExpr) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) import Id ( mkSysLocal, mkIdWithNewUniq, - lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv) + lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv), + SYN_IE(Id) ) import PprType ( GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) +import Outputable ( pprQuote, Outputable(..) ) import Pretty import SrcLoc ( noSrcLoc, SrcLoc ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) -import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) +import Type ( SYN_IE(Type) ) +import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) import Unique ( Unique{-instances-} ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, - mapUs, thenUs, returnUs, SYN_IE(UniqSM) ) + mapUs, thenUs, returnUs, SYN_IE(UniqSM), + UniqSupply ) import Util ( assoc, mapAccumL, zipWithEqual, panic ) infixr 9 `thenDs` @@ -128,18 +131,18 @@ mapAndUnzipDs f (x:xs) zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] -zipWithDs f [] [] = returnDs [] +zipWithDs f [] ys = returnDs [] zipWithDs f (x:xs) (y:ys) = f x y `thenDs` \ r -> zipWithDs f xs ys `thenDs` \ rs -> returnDs (r:rs) --- Note: crashes if lists not equal length (like zipWithEqual) \end{code} And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes it easier to read debugging output. + \begin{code} newLocalDs :: FAST_STRING -> Type -> DsM Id newLocalDs nm ty us loc mod_and_grp env warns @@ -201,41 +204,19 @@ getModuleAndGroupDs us loc mod_and_grp env warns \end{code} \begin{code} -type DsIdEnv = IdEnv CoreExpr +type DsIdEnv = IdEnv Id -extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a +extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a extendEnvDs pairs then_do us loc mod_and_grp old_env warns - = case splitUniqSupply us of { (s1, s2) -> - let - revised_pairs = subst_all pairs s1 - in - then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns - } - where - subst_all pairs = mapUs subst pairs - - subst (v, expr) - = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr -> - returnUs (v, new_expr) + = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns -lookupEnvDs :: Id -> DsM (Maybe CoreExpr) +lookupEnvDs :: Id -> DsM Id lookupEnvDs id us loc mod_and_grp env warns - = (lookupIdEnv env id, warns) - -- Note: we don't assert anything about the Id - -- being looked up. There's not really anything - -- much to say about it. (WDP 94/06) - -lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr -lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns = (case (lookupIdEnv env id) of - Nothing -> deflt + Nothing -> id Just xx -> xx, warns) - -lookupId :: [(Id, a)] -> Id -> a -lookupId env id - = assoc "lookupId" env id \end{code} %************************************************************************ @@ -260,42 +241,43 @@ data DsMatchKind | DoBindMatch deriving () -pprDsWarnings :: PprStyle -> DsWarnings -> Pretty +pprDsWarnings :: PprStyle -> DsWarnings -> Doc pprDsWarnings sty warns - = ppAboves (map pp_warn (bagToList warns)) + = vcat (map pp_warn (bagToList warns)) where - pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), + pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"), case flavour of - Shadowed -> ppPStr SLIT("shadowed") - Incomplete -> ppPStr SLIT("possibly incomplete")] + Shadowed -> ptext SLIT("shadowed") + Incomplete -> ptext SLIT("possibly incomplete")] pp_warn (flavour, DsMatchContext kind pats loc) - = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) - 4 (ppHang msg + = hang (hcat [ppr PprForUser loc, ptext SLIT(": ")]) + 4 (hang msg 4 (pp_match kind pats)) where msg = case flavour of - Shadowed -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped") - Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns") + Shadowed -> ptext SLIT("Warning: Pattern match(es) completely overlapped") + Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns") pp_match (FunMatch fun) pats - = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] + = hsep [ptext SLIT("in the definition of function"), ppr sty fun] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a group of case alternatives beginning:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a group of case alternatives beginning:")) + 4 (ppr_pats pats) pp_match PatBindMatch pats - = ppHang (ppPStr SLIT("in a pattern binding:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a pattern binding:")) + 4 (ppr_pats pats) pp_match LambdaMatch pats - = ppHang (ppPStr SLIT("in a lambda abstraction:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a lambda abstraction:")) + 4 (ppr_pats pats) pp_match DoBindMatch pats - = ppHang (ppPStr SLIT("in a `do' pattern binding:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a `do' pattern binding:")) + 4 (ppr_pats pats) - pp_arrow_dotdotdot = ppPStr SLIT("-> ...") + ppr_pats pats = pprQuote sty $ \ sty -> + sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")] \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 3fdc1d3..67863c9 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -23,6 +23,7 @@ module DsUtils ( mkSelectorBinds, mkTupleBind, mkTupleExpr, + mkTupleSelector, selectMatchVars, showForErr ) where @@ -33,7 +34,7 @@ IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) -import DsHsSyn ( outPatType ) +import DsHsSyn ( outPatType, collectTypedPatBinders ) import CoreSyn import DsMonad @@ -41,18 +42,19 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) -import Pretty ( ppShow, ppBesides, ppStr ) +import Pretty ( Doc, hcat, text ) import Id ( idType, dataConArgTys, -- pprId{-ToDo:rm-}, SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) import PprType ( GenType, GenTyVar ) +import PrimOp ( PrimOp ) import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, mkTheta, isUnboxedType, applyTyCon, getAppTyCon, - GenType {- instances -} + GenType {- instances -}, SYN_IE(Type) ) -import TyVar ( GenTyVar {- instances -} ) +import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar) ) import TysPrim ( voidTy ) import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) @@ -60,8 +62,37 @@ import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) import Unique ( Unique ) import Usage ( SYN_IE(UVar) ) import SrcLoc ( SrcLoc {- instance Outputable -} ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif + +\end{code} + + +%************************************************************************ +%* * +%* Selecting match variables +%* * +%************************************************************************ + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. + +\begin{code} +selectMatchVars :: [TypecheckedPat] -> DsM [Id] +selectMatchVars pats + = mapDs var_from_pat_maybe pats + where + var_from_pat_maybe (VarPat var) = returnDs var + var_from_pat_maybe (AsPat var pat) = returnDs var + var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat + var_from_pat_maybe other_pat + = newSysLocalDs (outPatType other_pat) -- OK, better make up one... \end{code} + %************************************************************************ %* * %* type synonym EquationInfo and access functions for its pieces * @@ -305,7 +336,7 @@ mkPrimDs op args \begin{code} showForErr :: Outputable a => a -> String -- Boring but useful -showForErr thing = ppShow 80 (ppr PprForUser thing) +showForErr thing = show (ppr PprQuote thing) mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied @@ -315,7 +346,7 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr "|", ppStr msg]) + full_msg = show (hcat [ppr PprForUser src_loc, text "|", text msg]) msg_lit = NoRepStr (_PK_ full_msg) in returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) @@ -344,23 +375,25 @@ even more helpful. Something very similar happens for pattern-bound expressions. \begin{code} -mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic - -> TypecheckedPat -- The pattern - -> [(Id,Id)] -- Monomorphic and polymorphic binders for - -- the pattern - -> CoreExpr -- Expression to which the pattern is bound +mkSelectorBinds :: TypecheckedPat -- The pattern + -> CoreExpr -- Expression to which the pattern is bound -> DsM [(Id,CoreExpr)] -mkSelectorBinds tyvars pat locals_and_globals val_expr - = if is_simple_tuple_pat pat then - mkTupleBind tyvars [] locals_and_globals val_expr - else - mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> - matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> - mkTupleBind tyvars [] locals_and_globals tuple_expr +mkSelectorBinds (VarPat v) val_expr + = returnDs [(v, val_expr)] + +mkSelectorBinds pat val_expr + | is_simple_tuple_pat pat + = mkTupleBind binders val_expr + + | otherwise + = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> + matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> + mkTupleBind binders tuple_expr + where - locals = [local | (local, _) <- locals_and_globals] - local_tuple = mkTupleExpr locals + binders = collectTypedPatBinders pat + local_tuple = mkTupleExpr binders res_ty = coreExprType local_tuple is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps @@ -369,111 +402,28 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr is_var_pat (VarPat v) = True is_var_pat other = False -- Even wild-card patterns aren't acceptable - pat_string = ppShow 80 (ppr PprForUser pat) + pat_string = show (ppr PprForUser pat) \end{code} -We're about to match against some patterns. We want to make some -@Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; -otherwise, make one up. -\begin{code} -selectMatchVars :: [TypecheckedPat] -> DsM [Id] -selectMatchVars pats - = mapDs var_from_pat_maybe pats - where - var_from_pat_maybe (VarPat var) = returnDs var - var_from_pat_maybe (AsPat var pat) = returnDs var - var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat - var_from_pat_maybe other_pat - = newSysLocalDs (outPatType other_pat) -- OK, better make up one... -\end{code} \begin{code} -mkTupleBind :: [TyVar] -- Abstract wrt these... - -> [DictVar] -- ... and these - - -> [(Id, Id)] -- Local, global pairs, equal in number - -- to the size of the tuple. The types - -- of the globals is the generalisation of - -- the corresp local, wrt the tyvars and dicts +mkTupleBind :: [Id] -- Names of tuple components + -> CoreExpr -- Expr whose value is a tuple of correct type + -> DsM [(Id, CoreExpr)] -- Bindings for the globals - -> CoreExpr -- Expr whose value is a tuple; the expression - -- may mention the tyvars and dicts - - -> DsM [(Id, CoreExpr)] -- Bindings for the globals -\end{code} -The general call is -\begin{verbatim} - mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr -\end{verbatim} -If $n=1$, the result is: -\begin{verbatim} - g1 = /\ tyvars -> \ dicts -> rhs -\end{verbatim} -Otherwise, the result is: -\begin{verbatim} - tup = /\ tyvars -> \ dicts -> tup_expr - g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of - (l1, ..., ln) -> l1 - ...etc... -\end{verbatim} +mkTupleBind [local] tuple_expr + = returnDs [(local, tuple_expr)] -\begin{code} -mkTupleBind tyvars dicts [(local,global)] tuple_expr - = returnDs [(global, mkLam tyvars dicts tuple_expr)] +mkTupleBind locals tuple_expr + = newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var -> + let + mk_bind local = (local, mkTupleSelector locals local (Var tuple_var)) + in + returnDs ( (tuple_var, tuple_expr) : + map mk_bind locals ) \end{code} -The general case: - -\begin{code} -mkTupleBind tyvars dicts local_global_prs tuple_expr - = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $ - - newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> - - zipWithDs (mk_selector (Var tuple_var)) - local_global_prs - [(0::Int) .. (length local_global_prs - 1)] - `thenDs` \ tup_selectors -> - returnDs ( - (tuple_var, mkLam tyvars dicts tuple_expr) - : tup_selectors - ) - where - locals, globals :: [Id] - locals = [local | (local,global) <- local_global_prs] - globals = [global | (local,global) <- local_global_prs] - - no_of_binders = length local_global_prs - tyvar_tys = mkTyVarTys tyvars - - tuple_var_ty :: Type - tuple_var_ty - = mkForAllTys tyvars $ - mkRhoTy theta $ - applyTyCon (tupleTyCon no_of_binders) - (map idType locals) - where - theta = mkTheta (map idType dicts) - - mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr) - - mk_selector tuple_var_expr (local, global) which_local - = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders -> - let - selected = binders !! which_local - in - returnDs ( - global, - mkLam tyvars dicts ( - mkTupleSelector - (mkValApp (mkTyApp tuple_var_expr tyvar_tys) - (map VarArg dicts)) - binders - selected) - ) -\end{code} @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it has only one element, it is the identity function. @@ -499,19 +449,19 @@ If there is just one id in the ``tuple'', then the selector is just the identity. \begin{code} -mkTupleSelector :: CoreExpr -- Scrutinee - -> [Id] -- The tuple args +mkTupleSelector :: [Id] -- The tuple args -> Id -- The selected one + -> CoreExpr -- Scrutinee -> CoreExpr -mkTupleSelector expr [] the_var = panic "mkTupleSelector" +mkTupleSelector [] the_var scrut = panic "mkTupleSelector" -mkTupleSelector expr [var] should_be_the_same_var +mkTupleSelector [var] should_be_the_same_var scrut = ASSERT(var == should_be_the_same_var) - expr + scrut -mkTupleSelector expr vars the_var - = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)] +mkTupleSelector vars the_var scrut + = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)] NoDefault) where arity = length vars diff --git a/ghc/compiler/deSugar/Match.hi-boot b/ghc/compiler/deSugar/Match.hi-boot new file mode 100644 index 0000000..e76bc35 --- /dev/null +++ b/ghc/compiler/deSugar/Match.hi-boot @@ -0,0 +1,6 @@ +_interface_ Match 1 +_exports_ +Match match matchSimply; +_declarations_ +1 match _:_ [Id.Id] -> [DsUtils.EquationInfo] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;; +1 matchSimply _:_ CoreSyn.CoreExpr -> TcHsSyn.TypecheckedPat -> Type.Type -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;; diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 7fb28b1..7629999 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -12,7 +12,8 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons -- and to break dsExpr/dsBinds-ish loop -import HsSyn hiding ( collectBinders{-also from CoreSyn-} ) +import CmdLineOpts ( opt_WarnIncompletePatterns ) +import HsSyn import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) import DsHsSyn ( outPatType, collectTypedPatBinders ) @@ -28,16 +29,17 @@ import MatchLit ( matchLiterals ) import FieldLabel ( FieldLabel {- Eq instance -} ) import Id ( idType, dataConFieldLabels, dataConArgTys, recordSelectorFieldLabel, - GenId{-instance-} + GenId{-instance-}, SYN_IE(Id) ) import Name ( Name {--O only-} ) import PprStyle ( PprStyle(..) ) -import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) +import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) +import Pretty ( Doc ) import PrelVals ( pAT_ERROR_ID ) import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts, - instantiateTauTy + instantiateTauTy, SYN_IE(Type) ) -import TyVar ( GenTyVar{-instance Eq-} ) +import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, addrPrimTy, wordPrimTy ) @@ -49,6 +51,10 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, ) import Unique ( Unique{-instance Eq-} ) import Util ( panic, pprPanic, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif + \end{code} The function @match@ is basically the same as in the Wadler chapter, @@ -316,12 +322,9 @@ tidy1 v (WildPat ty) match_result -} tidy1 v (LazyPat pat) match_result - = mkSelectorBinds [] pat l_to_l (Var v) `thenDs` \ sel_binds -> + = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds -> returnDs (WildPat (idType v), mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result) - where - l_to_l = binders `zip` binders -- Boring - binders = collectTypedPatBinders pat -- re-express as (ConPat ...) [directly] @@ -631,8 +634,10 @@ matchWrapper kind matches error_string -- Check for incomplete pattern match (case match_result of - MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt - other -> returnDs () + MatchResult CanFail result_ty match_fn cxt + | opt_WarnIncompletePatterns + -> dsIncompleteWarn cxt + other -> returnDs () ) `thenDs` \ _ -> extractMatchResult match_result fail_expr `thenDs` \ result_expr -> @@ -730,3 +735,4 @@ flattenMatches kind (match : matches) pats = reverse pats_so_far -- They've accumulated in reverse order \end{code} + diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index c94ce52..3ccebcb 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -17,7 +17,7 @@ import DsHsSyn ( outPatType ) import DsMonad import DsUtils -import Id ( isDataCon, GenId{-instances-} ) +import Id ( isDataCon, GenId{-instances-}, SYN_IE(Id) ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index c7e4bc1..cac28be 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -17,14 +17,14 @@ import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) ) import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) ) -import Id ( GenId {- instance Eq -} ) +import Id ( GenId {- instance Eq -}, SYN_IE(Id) ) import DsMonad import DsUtils import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) -import Type ( isPrimType ) +import Type ( isPrimType, SYN_IE(Type) ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs index f3818df..ed61365 100644 --- a/ghc/compiler/deforest/Cyclic.lhs +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -97,7 +97,7 @@ of the expression being returned. > loop ls (Var (Label e e1)) > = > d2c e `thenUs` \core_e -> ->-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $ +>-- trace ("loop:\n" ++ show (ppr PprDebug core_e)) $ > mapUs (\(f,e',val_args,ty_args) -> > renameExprs e' e `thenUs` \r -> @@ -172,8 +172,8 @@ new function... > if f `elem` ls' then > d2c e' `thenUs` \core_e' -> > trace ("In Forward Loop " ++ -> ppShow 80 (ppr PprDebug f) ++ "\n" ++ -> ppShow 80 (ppr PprDebug core_e')) $ +> show (ppr PprDebug f) ++ "\n" ++ +> show (ppr PprDebug core_e')) $ > if f `notElem` (freeVars (head back_loops)) then > returnUs (ls', bs, bls, head back_loops) > else @@ -241,7 +241,7 @@ Comment out the next block to disable back-loops. ToDo: trace all of them. > if not (null back_loops) then > d2c e' `thenUs` \core_e -> > trace ("Floating back loop:\n" -> ++ ppShow 80 (ppr PprDebug core_e)) +> ++ show (ppr PprDebug core_e)) > returnUs (ls', bs, back_loops ++ bls, e') > else > returnUs res @@ -350,7 +350,7 @@ expressions and function right hand sides that call this function. > t = foldl App (Var (DefArgVar new_id)) > (map mkVar fvs) > in -> trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $ +> trace ("adding " ++ show (length fvs) ++ " args to " ++ show (ppr PprDebug id)) $ > ((new_id, mkValLam fvs e), [(id,t)]) > where > fvs = case e of diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs index 14802be..26890c0 100644 --- a/ghc/compiler/deforest/Def2Core.lhs +++ b/ghc/compiler/deforest/Def2Core.lhs @@ -153,4 +153,4 @@ XXX - in here becuase if it goes in DefUtils we've got mutual recursion. > defPanic :: String -> String -> DefExpr -> UniqSM a > defPanic modl fun expr = > d2c expr `thenUs` \expr -> -> panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr)) +> panic (modl ++ "(" ++ fun ++ "): " ++ show (ppr PprDebug expr)) diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs index d5cd03c..57a2230 100644 --- a/ghc/compiler/deforest/DefExpr.lhs +++ b/ghc/compiler/deforest/DefExpr.lhs @@ -310,7 +310,7 @@ should an unfolding be required. > {- panic > ("DefExpr(tran): Deforestable id `" -> ++ ppShow 80 (ppr PprDebug id) +> ++ show (ppr PprDebug id) > ++ "' doesn't have an unfolding.") -} ----------------------------------------------------------------------------- @@ -449,14 +449,14 @@ and substitute the new function calls throughout the function set. > ++ showIds evs > ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n" > ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res -> where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n" +> where showBind (v,e) = show (ppr PprDebug v) ++ "=\n" ++ show (ppr PprDebug e) ++ "\n" > tranRecBind sw p t (id,e) = > tran sw p t e [] `thenUs` \e -> > returnUs (applyTypeEnvToId t id,e) > showIds :: [Id] -> String -> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids) +> showIds ids = "(" ++ concat (map ((' ' :) . show . ppr PprDebug) ids) > ++ " )" ----------------------------------------------------------------------------- diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs index 62ab803..9b039d4 100644 --- a/ghc/compiler/deforest/DefUtils.lhs +++ b/ghc/compiler/deforest/DefUtils.lhs @@ -340,8 +340,8 @@ or otherwise global ids. > d2c (strip u) `thenUs` \u -> > d2c (strip u') `thenUs` \u' -> > trace ("failed consistency check:\n" ++ -> ppShow 80 (ppr PprDebug u) ++ "\n" ++ -> ppShow 80 (ppr PprDebug u')) +> show (ppr PprDebug u) ++ "\n" ++ +> show (ppr PprDebug u')) > (returnUs (InconsistentRenaming r)) > else > trace "Renaming!" (returnUs (IsRenaming r)) diff --git a/ghc/compiler/deforest/Deforest.lhs b/ghc/compiler/deforest/Deforest.lhs index 471482f..820ca23 100644 --- a/ghc/compiler/deforest/Deforest.lhs +++ b/ghc/compiler/deforest/Deforest.lhs @@ -78,7 +78,7 @@ for xs as unfoldable, too. > > defProg sw p (NonRec v e : bs) = > trace ("Processing: `" ++ -> ppShow 80 (ppr PprDebug v) ++ "'\n") ( +> show (ppr PprDebug v) ++ "'\n") ( > tran sw p nullTyVarEnv e [] `thenUs` \e -> > mkLoops e `thenUs` \(extracted,e) -> > let e' = mkDefLetrec extracted e in @@ -112,17 +112,17 @@ for xs as unfoldable, too. > > defRecBind sw p (v,e) = > trace ("Processing: `" ++ -> ppShow 80 (ppr PprDebug v) ++ "'\n") ( +> show (ppr PprDebug v) ++ "'\n") ( > tran sw p nullTyVarEnv e [] `thenUs` \e' -> > mkLoops e' `thenUs` \(bs,e') -> > let e'' = mkDefLetrec bs e' in > > d2c e'' `thenUs` \core_e -> -> let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ -> "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n" +> let showBind (v,e) = show (ppr PprDebug v) ++ +> "=\n" ++ show (ppr PprDebug e) ++ "\n" > in > trace ("Extracting from `" ++ -> ppShow 80 (ppr PprDebug v) ++ "'\n" +> show (ppr PprDebug v) ++ "'\n" > ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $ > > if deforestable v diff --git a/ghc/compiler/hsSyn/HsBasic.lhs b/ghc/compiler/hsSyn/HsBasic.lhs index b6bf85e..156aa0e 100644 --- a/ghc/compiler/hsSyn/HsBasic.lhs +++ b/ghc/compiler/hsSyn/HsBasic.lhs @@ -12,6 +12,9 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(Ratio(Rational)) import Pretty +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} %************************************************************************ @@ -65,16 +68,16 @@ negLiteral (HsFrac f) = HsFrac (-f) \begin{code} instance Outputable HsLit where - ppr sty (HsChar c) = ppStr (show c) - ppr sty (HsCharPrim c) = ppBeside (ppStr (show c)) (ppChar '#') - ppr sty (HsString s) = ppStr (show s) - ppr sty (HsStringPrim s) = ppBeside (ppStr (show s)) (ppChar '#') - ppr sty (HsInt i) = ppInteger i - ppr sty (HsFrac f) = ppRational f - ppr sty (HsFloatPrim f) = ppBeside (ppRational f) (ppChar '#') - ppr sty (HsDoublePrim d) = ppBeside (ppRational d) (ppStr "##") - ppr sty (HsIntPrim i) = ppBeside (ppInteger i) (ppChar '#') - ppr sty (HsLitLit s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"] + ppr sty (HsChar c) = text (show c) + ppr sty (HsCharPrim c) = (<>) (text (show c)) (char '#') + ppr sty (HsString s) = text (show s) + ppr sty (HsStringPrim s) = (<>) (text (show s)) (char '#') + ppr sty (HsInt i) = integer i + ppr sty (HsFrac f) = rational f + ppr sty (HsFloatPrim f) = (<>) (rational f) (char '#') + ppr sty (HsDoublePrim d) = (<>) (rational d) (text "##") + ppr sty (HsIntPrim i) = (<>) (integer i) (char '#') + ppr sty (HsLitLit s) = hcat [text "``", ptext s, text "''"] \end{code} %************************************************************************ @@ -89,12 +92,12 @@ data FixityDirection = InfixL | InfixR | InfixN deriving(Eq) instance Outputable Fixity where - ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] + ppr sty (Fixity prec dir) = hcat [ppr sty dir, space, int prec] instance Outputable FixityDirection where - ppr sty InfixL = ppPStr SLIT("infixl") - ppr sty InfixR = ppPStr SLIT("infixr") - ppr sty InfixN = ppPStr SLIT("infix") + ppr sty InfixL = ptext SLIT("infixl") + ppr sty InfixR = ptext SLIT("infixr") + ppr sty InfixN = ptext SLIT("infix") instance Eq Fixity where -- Used to determine if two fixities conflict (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 diff --git a/ghc/compiler/hsSyn/HsBinds.hi-boot b/ghc/compiler/hsSyn/HsBinds.hi-boot new file mode 100644 index 0000000..0cfe242 --- /dev/null +++ b/ghc/compiler/hsSyn/HsBinds.hi-boot @@ -0,0 +1,10 @@ +_interface_ HsBinds 1 +_exports_ +HsBinds HsBinds nullBinds; +_instances_ +instance _forall_ [a b c d] => {Outputable.Outputable (HsBinds.HsBinds a b c d)} = $d1; +_declarations_ +1 $d1 _:_ _forall_ [a b c d] => {Outputable.Outputable (HsBinds.HsBinds a b c d)} ;; +1 data HsBinds a b c d ; +1 nullBinds _:_ _forall_ [a b c d] => HsBinds.HsBinds a b c d -> PrelBase.Bool ;; + diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 8a02327..1fe3a29 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -23,11 +23,11 @@ import CoreSyn ( SYN_IE(CoreExpr) ) --others: import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) -import Name ( pprNonSym, getOccName, OccName ) +import Name ( getOccName, OccName, NamedThing(..) ) import Outputable ( interpp'SP, ifnotPprForUser, Outputable(..){-instance * (,)-} ) -import PprCore ( GenCoreExpr {- instance Outputable -} ) +import PprCore --( GenCoreExpr {- instance Outputable -} ) import PprType ( GenTyVar {- instance Outputable -} ) import Pretty import Bag @@ -57,20 +57,79 @@ data HsBinds tyvar uvar id pat -- binders and bindees | ThenBinds (HsBinds tyvar uvar id pat) (HsBinds tyvar uvar id pat) - | SingleBind (Bind tyvar uvar id pat) + | MonoBind (MonoBinds tyvar uvar id pat) + [Sig id] -- Empty on typechecker output + RecFlag - | BindWith -- Bind with a type signature. - -- These appear only on typechecker input - -- (HsType [in Sigs] can't appear on output) - (Bind tyvar uvar id pat) - [Sig id] +type RecFlag = Bool +recursive = True +nonRecursive = False +\end{code} + +\begin{code} +nullBinds :: HsBinds tyvar uvar id pat -> Bool + +nullBinds EmptyBinds = True +nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 +nullBinds (MonoBind b _ _) = nullMonoBinds b +\end{code} + +\begin{code} +instance (Outputable pat, NamedThing id, Outputable id, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => + Outputable (HsBinds tyvar uvar id pat) where + + ppr sty EmptyBinds = empty + ppr sty (ThenBinds binds1 binds2) + = ($$) (ppr sty binds1) (ppr sty binds2) + ppr sty (MonoBind bind sigs is_rec) + = vcat [ + ifnotPprForUser sty (ptext rec_str), + if null sigs + then empty + else vcat (map (ppr sty) sigs), + ppr sty bind + ] + where + rec_str | is_rec = SLIT("{- rec -}") + | otherwise = SLIT("{- nonrec -}") +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings: @MonoBinds@} +%* * +%************************************************************************ + +Global bindings (where clauses) + +\begin{code} +data MonoBinds tyvar uvar id pat + = EmptyMonoBinds + + | AndMonoBinds (MonoBinds tyvar uvar id pat) + (MonoBinds tyvar uvar id pat) + + | PatMonoBind pat + (GRHSsAndBinds tyvar uvar id pat) + SrcLoc + + | FunMonoBind id + Bool -- True => infix declaration + [Match tyvar uvar id pat] -- must have at least one Match + SrcLoc + + | VarMonoBind id -- TRANSLATION + (HsExpr tyvar uvar id pat) + + | CoreMonoBind id -- TRANSLATION + CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! | AbsBinds -- Binds abstraction; TRANSLATION - [tyvar] - [id] -- Dicts - [(id, id)] -- (momonmorphic, polymorphic) pairs - [(id, HsExpr tyvar uvar id pat)] -- local dictionaries - (Bind tyvar uvar id pat) -- "the business end" + [tyvar] -- Type variables + [id] -- Dicts + [([tyvar], id, id)] -- (type variables, polymorphic, momonmorphic) triples + (MonoBinds tyvar uvar id pat) -- The "business end" -- Creates bindings for *new* (polymorphic, overloaded) locals -- in terms of *old* (monomorphic, non-overloaded) ones. @@ -82,15 +141,14 @@ data HsBinds tyvar uvar id pat -- binders and bindees What AbsBinds means ~~~~~~~~~~~~~~~~~~~ - AbsBinds [a,b] + AbsBinds tvs [d1,d2] - [(fm,fp), (gm,gp)] - [d3 = d1, - d4 = df d2] + [(tvs1, f1p, f1m), + (tvs2, f2p, f2m)] BIND means - fp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND + f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND in fm gp = ...same again, with gm instead of fm @@ -106,35 +164,43 @@ So the desugarer tries to do a better job: in (fm,gm) \begin{code} -nullBinds :: HsBinds tyvar uvar id pat -> Bool +nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool -nullBinds EmptyBinds = True -nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 -nullBinds (SingleBind b) = nullBind b -nullBinds (BindWith b _) = nullBind b -nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b +nullMonoBinds EmptyMonoBinds = True +nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2 +nullMonoBinds other_monobind = False + +andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat +andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds \end{code} \begin{code} -instance (Outputable pat, NamedThing id, Outputable id, +instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (HsBinds tyvar uvar id pat) where + Outputable (MonoBinds tyvar uvar id pat) where + ppr sty EmptyMonoBinds = empty + ppr sty (AndMonoBinds binds1 binds2) + = ($$) (ppr sty binds1) (ppr sty binds2) - ppr sty EmptyBinds = ppNil - ppr sty (ThenBinds binds1 binds2) - = ppAbove (ppr sty binds1) (ppr sty binds2) - ppr sty (SingleBind bind) = ppr sty bind - ppr sty (BindWith bind sigs) - = ppAbove (if null sigs - then ppNil - else ppAboves (map (ppr sty) sigs)) - (ppr sty bind) - ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds) - = ppAbove (ppSep [ppPStr SLIT("AbsBinds"), - ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack], - ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack], - ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]]) - (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds))) + ppr sty (PatMonoBind pat grhss_n_binds locn) + = hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) + + ppr sty (FunMonoBind fun inf matches locn) + = pprMatches sty (False, ppr sty fun) matches + -- ToDo: print infix if appropriate + + ppr sty (VarMonoBind name expr) + = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr) + + ppr sty (CoreMonoBind name expr) + = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr) + + ppr sty (AbsBinds tyvars dictvars exports val_binds) + = ($$) (sep [ptext SLIT("AbsBinds"), + brackets (interpp'SP sty tyvars), + brackets (interpp'SP sty dictvars), + brackets (interpp'SP sty exports)]) + (nest 4 (ppr sty val_binds)) \end{code} %************************************************************************ @@ -179,131 +245,31 @@ data Sig name \begin{code} instance (NamedThing name, Outputable name) => Outputable (Sig name) where ppr sty (Sig var ty _) - = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")]) + = hang (hsep [ppr sty var, ptext SLIT("::")]) 4 (ppr sty ty) ppr sty (ClassOpSig var _ ty _) - = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) + = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")]) 4 (ppr sty ty) ppr sty (DeforestSig var _) - = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var]) - 4 (ppStr "#-") + = hang (hsep [text "{-# DEFOREST", ppr sty var]) + 4 (text "#-") ppr sty (SpecSig var ty using _) - = ppHang (ppCat [ppStr "{-# SPECIALIZE", pprNonSym sty var, ppPStr SLIT("::")]) - 4 (ppCat [ppr sty ty, pp_using using, ppStr "#-}"]) + = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")]) + 4 (hsep [ppr sty ty, pp_using using, text "#-}"]) where - pp_using Nothing = ppNil - pp_using (Just me) = ppCat [ppChar '=', ppr sty me] + pp_using Nothing = empty + pp_using (Just me) = hsep [char '=', ppr sty me] ppr sty (InlineSig var _) - = ppCat [ppStr "{-# INLINE", pprNonSym sty var, ppStr "#-}"] + = hsep [text "{-# INLINE", ppr sty var, text "#-}"] ppr sty (MagicUnfoldingSig var str _) - = ppCat [ppStr "{-# MAGIC_UNFOLDING", pprNonSym sty var, ppPStr str, ppStr "#-}"] -\end{code} - -%************************************************************************ -%* * -\subsection{Binding: @Bind@} -%* * -%************************************************************************ - -\begin{code} -data Bind tyvar uvar id pat -- binders and bindees - = EmptyBind -- because it's convenient when parsing signatures - | NonRecBind (MonoBinds tyvar uvar id pat) - | RecBind (MonoBinds tyvar uvar id pat) -\end{code} - -\begin{code} -nullBind :: Bind tyvar uvar id pat -> Bool - -nullBind EmptyBind = True -nullBind (NonRecBind bs) = nullMonoBinds bs -nullBind (RecBind bs) = nullMonoBinds bs -\end{code} - -\begin{code} -bindIsRecursive :: Bind tyvar uvar id pat -> Bool - -bindIsRecursive EmptyBind = False -bindIsRecursive (NonRecBind _) = False -bindIsRecursive (RecBind _) = True -\end{code} - -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Bind tyvar uvar id pat) where - ppr sty EmptyBind = ppNil - ppr sty (NonRecBind binds) - = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- nonrec -}"))) - (ppr sty binds) - ppr sty (RecBind binds) - = ppAbove (ifnotPprForUser sty (ppPStr SLIT("{- rec -}"))) - (ppr sty binds) -\end{code} - -%************************************************************************ -%* * -\subsection{Bindings: @MonoBinds@} -%* * -%************************************************************************ - -Global bindings (where clauses) - -\begin{code} -data MonoBinds tyvar uvar id pat - = EmptyMonoBinds - | AndMonoBinds (MonoBinds tyvar uvar id pat) - (MonoBinds tyvar uvar id pat) - | PatMonoBind pat - (GRHSsAndBinds tyvar uvar id pat) - SrcLoc - | FunMonoBind id - Bool -- True => infix declaration - [Match tyvar uvar id pat] -- must have at least one Match - SrcLoc - - | VarMonoBind id -- TRANSLATION - (HsExpr tyvar uvar id pat) - - | CoreMonoBind id -- TRANSLATION - CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! -\end{code} - -\begin{code} -nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool - -nullMonoBinds EmptyMonoBinds = True -nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2 -nullMonoBinds other_monobind = False -\end{code} - -\begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (MonoBinds tyvar uvar id pat) where - ppr sty EmptyMonoBinds = ppNil - ppr sty (AndMonoBinds binds1 binds2) - = ppAbove (ppr sty binds1) (ppr sty binds2) - - ppr sty (PatMonoBind pat grhss_n_binds locn) - = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds) - - ppr sty (FunMonoBind fun inf matches locn) - = pprMatches sty (False, ppr sty fun) matches - -- ToDo: print infix if appropriate - - ppr sty (VarMonoBind name expr) - = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr) - - ppr sty (CoreMonoBind name expr) - = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr) + = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"] \end{code} %************************************************************************ @@ -326,16 +292,10 @@ it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) collectTopBinders EmptyBinds = emptyBag -collectTopBinders (SingleBind b) = collectBinders b -collectTopBinders (BindWith b _) = collectBinders b +collectTopBinders (MonoBind b _ _) = collectMonoBinders b collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2 -collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc) -collectBinders EmptyBind = emptyBag -collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds -collectBinders (RecBind monobinds) = collectMonoBinders monobinds - collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc) collectMonoBinders EmptyMonoBinds = emptyBag collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat)) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 8e60262..6a37f2d 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -32,6 +32,9 @@ import Literal ( Literal ) import Outputable ( Outputable(..) ) import Pretty import Util ( panic ) +#if __GLASGOW_HASKELL__ >= 202 +import CostCentre +#endif \end{code} %************************************************************************ @@ -104,57 +107,57 @@ instance Outputable name => Outputable (UfExpr name) where ppr sty (UfLit l) = ppr sty l ppr sty (UfCon c as) - = ppCat [ppStr "UfCon", ppr sty c, ppr sty as, ppChar ')'] + = hsep [text "UfCon", ppr sty c, ppr sty as, char ')'] ppr sty (UfPrim o as) - = ppCat [ppStr "UfPrim", ppr sty o, ppr sty as, ppChar ')'] + = hsep [text "UfPrim", ppr sty o, ppr sty as, char ')'] ppr sty (UfLam b body) - = ppCat [ppChar '\\', ppr sty b, ppPStr SLIT("->"), ppr sty body] + = hsep [char '\\', ppr sty b, ptext SLIT("->"), ppr sty body] ppr sty (UfApp fun (UfTyArg ty)) - = ppCat [ppr sty fun, ppChar '@', pprParendHsType sty ty] + = hsep [ppr sty fun, char '@', pprParendHsType sty ty] ppr sty (UfApp fun (UfLitArg lit)) - = ppCat [ppr sty fun, ppr sty lit] + = hsep [ppr sty fun, ppr sty lit] ppr sty (UfApp fun (UfVarArg var)) - = ppCat [ppr sty fun, ppr sty var] + = hsep [ppr sty fun, ppr sty var] ppr sty (UfCase scrut alts) - = ppCat [ppPStr SLIT("case"), ppr sty scrut, ppPStr SLIT("of {"), pp_alts alts, ppChar '}'] + = hsep [ptext SLIT("case"), ppr sty scrut, ptext SLIT("of {"), pp_alts alts, char '}'] where pp_alts (UfAlgAlts alts deflt) - = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] + = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt] where - pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs] + pp_alt (c,bs,rhs) = hsep [ppr sty c, ppr sty bs, ppr_arrow, ppr sty rhs] pp_alts (UfPrimAlts alts deflt) - = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] + = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt] where - pp_alt (l,rhs) = ppCat [ppr sty l, ppr_arrow, ppr sty rhs] + pp_alt (l,rhs) = hsep [ppr sty l, ppr_arrow, ppr sty rhs] - pp_deflt UfNoDefault = ppNil - pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppr_arrow, ppr sty rhs] + pp_deflt UfNoDefault = empty + pp_deflt (UfBindDefault b rhs) = hsep [ppr sty b, ppr_arrow, ppr sty rhs] - ppr_arrow = ppPStr SLIT("->") + ppr_arrow = ptext SLIT("->") ppr sty (UfLet (UfNonRec b rhs) body) - = ppCat [ppPStr SLIT("let"), ppr sty b, ppEquals, ppr sty rhs, ppPStr SLIT("in"), ppr sty body] + = hsep [ptext SLIT("let"), ppr sty b, equals, ppr sty rhs, ptext SLIT("in"), ppr sty body] ppr sty (UfLet (UfRec pairs) body) - = ppCat [ppPStr SLIT("letrec {"), ppInterleave ppSemi (map pp_pair pairs), ppPStr SLIT("} in"), ppr sty body] + = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr sty body] where - pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs] + pp_pair (b,rhs) = hsep [ppr sty b, equals, ppr sty rhs] ppr sty (UfSCC uf_cc body) - = ppCat [ppPStr SLIT("_scc_ "), ppr sty body] + = hsep [ptext SLIT("_scc_ "), ppr sty body] instance Outputable name => Outputable (UfPrimOp name) where ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) = let - before = ppPStr (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) - after = if is_casm then ppStr "'' " else ppSP + before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ ")) + after = if is_casm then text "'' " else space in - ppBesides [before, ppPStr str, after, - ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] + hcat [before, ptext str, after, + brackets (ppr sty arg_tys), space, ppr sty result_ty] ppr sty (UfOtherOp op) = ppr sty op @@ -166,8 +169,8 @@ instance Outputable name => Outputable (UfArg name) where ppr sty (UfUsageArg name) = ppr sty name instance Outputable name => Outputable (UfBinder name) where - ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty ty] - ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppPStr SLIT("::"), ppr sty kind] + ppr sty (UfValBinder name ty) = hsep [ppr sty name, ptext SLIT("::"), ppr sty ty] + ppr sty (UfTyBinder name kind) = hsep [ppr sty name, ptext SLIT("::"), ppr sty kind] ppr sty (UfUsageBinder name) = ppr sty name \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d4f6628..ec185fe 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -23,15 +23,17 @@ import IdInfo import SpecEnv ( SpecEnv ) import HsCore ( UfExpr ) import HsBasic ( Fixity ) +import TyCon ( NewOrData(..) ) -- Just a boolean flag really -- others: -import Name ( pprSym, pprNonSym, getOccName, OccName ) +import Name --( getOccName, OccName ) import Outputable ( interppSP, interpp'SP, Outputable(..){-instance * []-} ) import Pretty import SrcLoc ( SrcLoc ) -import PprStyle ( PprStyle(..), ifaceStyle ) +import PprStyle ( PprStyle(..) ) +import Util \end{code} @@ -52,12 +54,20 @@ data HsDecl tyvar uvar name pat \end{code} \begin{code} -hsDeclName (TyD (TyData _ name _ _ _ _ _)) = name -hsDeclName (TyD (TyNew _ name _ _ _ _ _)) = name -hsDeclName (TyD (TySynonym name _ _ _)) = name -hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name -hsDeclName (SigD (IfaceSig name _ _ _)) = name +#ifdef DEBUG +hsDeclName :: (NamedThing name, Outputable name, Outputable pat, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) + => HsDecl tyvar uvar name pat -> name +#endif +hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name +hsDeclName (TyD (TySynonym name _ _ _)) = name +hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name +hsDeclName (SigD (IfaceSig name _ _ _)) = name +hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name -- Others don't make sense +#ifdef DEBUG +hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x) +#endif \end{code} \begin{code} @@ -72,9 +82,14 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (DefD def) = ppr sty def ppr sty (InstD inst) = ppr sty inst --- In interfaces, top-level binders are printed without their "Module." prefix -ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr) - | otherwise = ppr sty bndr +#ifdef DEBUG +instance (Ord3 name, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, + NamedThing name, Outputable name, Outputable pat) => + Ord3 (HsDecl tyvar uvar name pat) where +#else +instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where +#endif + d1 `cmp` d2 = hsDeclName d1 `cmp` hsDeclName d2 \end{code} @@ -88,7 +103,7 @@ ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr) data FixityDecl name = FixityDecl name Fixity SrcLoc instance Outputable name => Outputable (FixityDecl name) where - ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name] + ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name] \end{code} @@ -100,7 +115,8 @@ instance Outputable name => Outputable (FixityDecl name) where \begin{code} data TyDecl name - = TyData (Context name) -- context + = TyData NewOrData + (Context name) -- context name -- type constructor [HsTyVar name] -- type variables [ConDecl name] -- data constructors (empty if abstract) @@ -111,14 +127,6 @@ data TyDecl name (DataPragmas name) SrcLoc - | TyNew (Context name) -- context - name -- type constructor - [HsTyVar name] -- type variables - (ConDecl name) -- data constructor - (Maybe [name]) -- derivings; as above - (DataPragmas name) - SrcLoc - | TySynonym name -- type constructor [HsTyVar name] -- type variables (HsType name) -- synonym expansion @@ -131,41 +139,39 @@ instance (NamedThing name, Outputable name) => Outputable (TyDecl name) where ppr sty (TySynonym tycon tyvars mono_ty src_loc) - = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars) + = hang (pp_decl_head sty SLIT("type") empty tycon tyvars) 4 (ppr sty mono_ty) - ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc) + ppr sty (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) = pp_tydecl sty - (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars) + (pp_decl_head sty keyword (pp_context_and_arrow sty context) tycon tyvars) (pp_condecls sty condecls) derivings - - ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc) - = pp_tydecl sty - (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars) - (ppr sty condecl) - derivings + where + keyword = case new_or_data of + NewType -> SLIT("newtype") + DataType -> SLIT("data") pp_decl_head sty str pp_context tycon tyvars - = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon, - interppSP sty tyvars, ppPStr SLIT("=")] + = hsep [ptext str, pp_context, ppr sty tycon, + interppSP sty tyvars, ptext SLIT("=")] -pp_condecls sty [] = ppNil -- Curious! +pp_condecls sty [] = empty -- Curious! pp_condecls sty (c:cs) - = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs) + = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs) pp_tydecl sty pp_head pp_decl_rhs derivings - = ppHang pp_head 4 (ppSep [ + = hang pp_head 4 (sep [ pp_decl_rhs, case (derivings, sty) of - (Nothing,_) -> ppNil - (_,PprInterface) -> ppNil -- No derivings in interfaces - (Just ds,_) -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)] + (Nothing,_) -> empty + (_,PprInterface) -> empty -- No derivings in interfaces + (Just ds,_) -> hsep [ptext SLIT("deriving"), parens (interpp'SP sty ds)] ]) -pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty -pp_context_and_arrow sty [] = ppNil -pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")] +pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Doc +pp_context_and_arrow sty [] = empty +pp_context_and_arrow sty theta = hsep [pprContext sty theta, ptext SLIT("=>")] \end{code} A type for recording what types a datatype should be specialised to. @@ -182,7 +188,7 @@ instance (NamedThing name, Outputable name) => Outputable (SpecDataSig name) where ppr sty (SpecDataSig tycon ty _) - = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"] + = hsep [text "{-# SPECIALIZE data", ppr sty ty, text "#-}"] \end{code} %************************************************************************ @@ -193,22 +199,24 @@ instance (NamedThing name, Outputable name) \begin{code} data ConDecl name - = ConDecl name -- prefix-style con decl - [BangType name] + = ConDecl name -- Constructor name + (Context name) -- Existential context for this constructor + (ConDetails name) SrcLoc - | ConOpDecl (BangType name) -- infix-style con decl - name +data ConDetails name + = VanillaCon -- prefix-style con decl + [BangType name] + + | InfixCon -- infix-style con decl + (BangType name) (BangType name) - SrcLoc - | RecConDecl name + | RecCon -- record-style con decl [([name], BangType name)] -- list of "fields" - SrcLoc - | NewConDecl name -- newtype con decl + | NewCon -- newtype con decl (HsType name) - SrcLoc data BangType name = Banged (HsType name) -- HsType: to allow Haskell extensions @@ -217,31 +225,26 @@ data BangType name \begin{code} instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where + ppr sty (ConDecl con cxt con_details loc) + = pp_context_and_arrow sty cxt <+> ppr_con_details sty con con_details - ppr sty (ConDecl con tys _) - = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] +ppr_con_details sty con (InfixCon ty1 ty2) + = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2] - -- We print ConOpDecls in prefix form in interface files - ppr sty (ConOpDecl ty1 op ty2 _) - | ifaceStyle sty - = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2] - | otherwise - = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2] - - ppr sty (NewConDecl con ty _) - = ppCat [ppr_top_binder sty con, pprParendHsType sty ty] - ppr sty (RecConDecl con fields _) - = ppCat [ppr_top_binder sty con, - ppCurlies (ppInterleave pp'SP (map pp_field fields)) - ] - where - pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns), - ppPStr SLIT("::"), ppr_bang sty ty] +ppr_con_details sty con (VanillaCon tys) + = ppr sty con <+> hsep (map (ppr_bang sty) tys) + +ppr_con_details sty con (NewCon ty) + = ppr sty con <+> pprParendHsType sty ty -ppr_bang sty (Banged ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty) - -- The extra space helps the lexical analyser that lexes - -- interface files; it doesn't make the rigid operator/identifier - -- distinction, so "!a" is a valid identifier so far as it is concerned +ppr_con_details sty con (RecCon fields) + = ppr sty con <+> braces (hsep (punctuate comma (map ppr_field fields))) + where + ppr_field (ns, ty) = hsep (map (ppr sty) ns) <+> + ptext SLIT("::") <+> + ppr_bang sty ty + +ppr_bang sty (Banged ty) = ptext SLIT("!") <> pprParendHsType sty ty ppr_bang sty (Unbanged ty) = pprParendHsType sty ty \end{code} @@ -271,20 +274,15 @@ instance (NamedThing name, Outputable name, Outputable pat, | null sigs -- No "where" part = top_matter - | iface_style -- All on one line (for now at least) - = ppCat [top_matter, ppPStr SLIT("where"), - ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)] - | otherwise -- Laid out - = ppSep [ppCat [top_matter, ppPStr SLIT("where {")], - ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods) - `ppBeside` ppChar '}')] + = sep [hsep [top_matter, ptext SLIT("where {")], + nest 4 (vcat [sep (map ppr_sig sigs), + ppr sty methods, + char '}'])] where - top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context, - ppr_top_binder sty clas, ppr sty tyvar] - pp_sigs = map (ppr sty) sigs - pp_methods = ppr sty methods - iface_style = case sty of {PprInterface -> True; other -> False} + top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow sty context, + ppr sty clas, ppr sty tyvar] + ppr_sig sig = ppr sty sig <> semi \end{code} %************************************************************************ @@ -316,12 +314,12 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) | case sty of { PprInterface -> True; other -> False} || nullMonoBinds binds && null uprags - = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty] + = hsep [ptext SLIT("instance"), ppr sty inst_ty] | otherwise - = ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")], - ppNest 4 (ppr sty uprags), - ppNest 4 (ppr sty binds) ] + = vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")], + nest 4 (ppr sty uprags), + nest 4 (ppr sty binds) ] \end{code} A type for recording what instances the user wants to specialise; @@ -337,7 +335,7 @@ instance (NamedThing name, Outputable name) => Outputable (SpecInstSig name) where ppr sty (SpecInstSig clas ty _) - = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"] + = hsep [text "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, text "#-}"] \end{code} %************************************************************************ @@ -359,7 +357,7 @@ instance (NamedThing name, Outputable name) => Outputable (DefaultDecl name) where ppr sty (DefaultDecl tys src_loc) - = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys)) + = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys)) \end{code} %************************************************************************ @@ -377,7 +375,7 @@ data IfaceSig name instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where ppr sty (IfaceSig var ty _ _) - = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")]) + = hang (hsep [ppr sty var, ptext SLIT("::")]) 4 (ppr sty ty) data HsIdInfo name diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot new file mode 100644 index 0000000..f27e26c --- /dev/null +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot @@ -0,0 +1,11 @@ +_interface_ HsExpr 1 +_exports_ +HsExpr HsExpr Stmt; +_instances_ +instance _forall_ [a b c d] => {Outputable.Outputable (HsExpr a b c d)} = $d1; +instance _forall_ [a b c d] => {Outputable.Outputable (Stmt a b c d)} = $d2; +_declarations_ +1 $d1 _:_ _forall_ [a b c d] => {Outputable.Outputable (HsExpr a b c d)} ;; +1 $d2 _:_ _forall_ [a b c d] => {Outputable.Outputable (Stmt a b c d)} ;; +1 data HsExpr a b c d; +1 data Stmt a b c d; diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 936c612..db8e130 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -19,14 +19,16 @@ import HsTypes ( HsType ) -- others: import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) -import Name ( pprNonSym, pprSym ) -import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) +import Outputable --( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), userStyle ) import SrcLoc ( SrcLoc ) import Usage ( GenUsage{-instance-} ) --import Util ( panic{-ToDo:rm eventually-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +#endif \end{code} %************************************************************************ @@ -116,6 +118,8 @@ data HsExpr tyvar uvar id pat (HsRecordBinds tyvar uvar id pat) | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION + (GenType tyvar uvar) -- Type of *result* record (may differ from + -- type of input record) [id] -- Dicts needed for construction (HsRecordBinds tyvar uvar id pat) @@ -191,7 +195,7 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (HsExpr tyvar uvar id pat) where - ppr = pprExpr + ppr sty expr = pprQuote sty $ \ sty -> pprExpr sty expr \end{code} \begin{code} @@ -201,11 +205,11 @@ pprExpr sty (HsLit lit) = ppr sty lit pprExpr sty (HsLitOut lit _) = ppr sty lit pprExpr sty (HsLam match) - = ppCat [ppChar '\\', ppNest 2 (pprMatch sty True match)] + = hsep [char '\\', nest 2 (pprMatch sty True match)] pprExpr sty expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args)) + hang (pprExpr sty fun) 4 (sep (map (pprExpr sty) args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -219,16 +223,16 @@ pprExpr sty (OpApp e1 op fixity e2) pp_e2 = pprParendExpr sty e2 pp_prefixly - = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2]) + = hang (pprExpr sty op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = ppSep [pp_e1, ppCat [ppr sty v, pp_e2]] + = sep [pp_e1, hsep [ppr sty v, pp_e2]] pprExpr sty (NegApp e _) - = ppBeside (ppChar '-') (pprParendExpr sty e) + = (<>) (char '-') (pprParendExpr sty e) pprExpr sty (HsPar e) - = ppParens (pprExpr sty e) + = parens (pprExpr sty e) pprExpr sty (SectionL expr op) = case op of @@ -237,11 +241,9 @@ pprExpr sty (SectionL expr op) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr " \\ x_ ->", ppr sty op]) - 4 (ppCat [pp_expr, ppPStr SLIT("x_ )")]) - pp_infixly v - = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (ppr sty v) ppRparen ] + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr sty op]) + 4 (hsep [pp_expr, ptext SLIT("x_ )")]) + pp_infixly v = parens (sep [pp_expr, ppr sty v]) pprExpr sty (SectionR op expr) = case op of @@ -250,110 +252,106 @@ pprExpr sty (SectionR op expr) where pp_expr = pprParendExpr sty expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")]) - 4 (ppBeside pp_expr ppRparen) + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr sty op, ptext SLIT("x_")]) + 4 ((<>) pp_expr rparen) pp_infixly v - = ppSep [ ppBeside ppLparen (ppr sty v), - ppBeside pp_expr ppRparen ] + = parens (sep [ppr sty v, pp_expr]) pprExpr sty (HsCase expr matches _) - = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")], - ppNest 2 (pprMatches sty (True, ppNil) matches) ] + = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr sty expr), ptext SLIT("of")], + nest 2 (pprMatches sty (True, empty) matches) ] pprExpr sty (HsIf e1 e2 e3 _) - = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")], - ppNest 4 (pprExpr sty e2), - ppPStr SLIT("else"), - ppNest 4 (pprExpr sty e3)] + = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr sty e1), ptext SLIT("then")], + nest 4 (pprExpr sty e2), + ptext SLIT("else"), + nest 4 (pprExpr sty e3)] -- special case: let ... in let ... pprExpr sty (HsLet binds expr@(HsLet _ _)) - = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]), + = sep [hang (ptext SLIT("let")) 2 (hsep [ppr sty binds, ptext SLIT("in")]), ppr sty expr] pprExpr sty (HsLet binds expr) - = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds), - ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] + = sep [hang (ptext SLIT("let")) 2 (ppr sty binds), + hang (ptext SLIT("in")) 2 (ppr sty expr)] pprExpr sty (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp sty stmts pprExpr sty (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp sty stmts pprExpr sty (ExplicitList exprs) - = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) + = brackets (fsep (punctuate comma (map (pprExpr sty) exprs))) pprExpr sty (ExplicitListOut ty exprs) - = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)), - ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ] + = hcat [ brackets (fsep (punctuate comma (map (pprExpr sty) exprs))), + ifnotPprForUser sty ((<>) space (parens (pprGenType sty ty))) ] pprExpr sty (ExplicitTuple exprs) - = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs)) + = parens (sep (punctuate comma (map (pprExpr sty) exprs))) pprExpr sty (RecordCon con rbinds) = pp_rbinds sty (ppr sty con) rbinds pprExpr sty (RecordUpd aexp rbinds) = pp_rbinds sty (pprParendExpr sty aexp) rbinds -pprExpr sty (RecordUpdOut aexp _ rbinds) +pprExpr sty (RecordUpdOut aexp _ _ rbinds) = pp_rbinds sty (pprParendExpr sty aexp) rbinds pprExpr sty (ExprWithTySig expr sig) - = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::"))) + = hang ((<>) (nest 2 (pprExpr sty expr)) (ptext SLIT(" ::"))) 4 (ppr sty sig) pprExpr sty (ArithSeqIn info) - = ppBracket (ppr sty info) + = brackets (ppr sty info) pprExpr sty (ArithSeqOut expr info) - = case sty of - PprForUser -> - ppBracket (ppr sty info) - _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppSP, ppr sty info, ppRbrack] + | userStyle sty = brackets (ppr sty info) + | otherwise = brackets (hcat [parens (ppr sty expr), space, ppr sty info]) pprExpr sty (CCall fun args _ is_asm result_ty) - = ppHang (if is_asm - then ppBesides [ppPStr SLIT("_casm_ ``"), ppPStr fun, ppPStr SLIT("''")] - else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) - 4 (ppSep (map (pprParendExpr sty) args)) + = hang (if is_asm + then hcat [ptext SLIT("_casm_ ``"), ptext fun, ptext SLIT("''")] + else (<>) (ptext SLIT("_ccall_ ")) (ptext fun)) + 4 (sep (map (pprParendExpr sty) args)) pprExpr sty (HsSCC label expr) - = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']), + = sep [ (<>) (ptext SLIT("_scc_ ")) (hcat [char '"', ptext label, char '"']), pprParendExpr sty expr ] pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppPStr SLIT("/\\"), interppSP sty tyvars, ppPStr SLIT("->")]) + = hang (hsep [ptext SLIT("/\\"), interppSP sty tyvars, ptext SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (TyApp expr [ty]) - = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty) + = hang (pprExpr sty expr) 4 (pprParendGenType sty ty) pprExpr sty (TyApp expr tys) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty tys)) + = hang (pprExpr sty expr) + 4 (brackets (interpp'SP sty tys)) pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppPStr SLIT("\\{-dict-}"), interppSP sty dictvars, ppPStr SLIT("->")]) + = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP sty dictvars, ptext SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (DictApp expr [dname]) - = ppHang (pprExpr sty expr) 4 (ppr sty dname) + = hang (pprExpr sty expr) 4 (ppr sty dname) pprExpr sty (DictApp expr dnames) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty dnames)) + = hang (pprExpr sty expr) + 4 (brackets (interpp'SP sty dnames)) pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppPStr SLIT("\\{-classdict-}"), - ppBracket (interppSP sty dicts), - ppBracket (interppSP sty methods), - ppPStr SLIT("->")]) + = hang (hsep [ptext SLIT("\\{-classdict-}"), + brackets (interppSP sty dicts), + brackets (interppSP sty methods), + ptext SLIT("->")]) 4 (pprExpr sty expr) pprExpr sty (Dictionary dicts methods) - = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], - ppBracket (interpp'SP sty dicts), - ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] + = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP sty dicts), + brackets (interpp'SP sty methods)]) pprExpr sty (SingleDict dname) - = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] + = hsep [ptext SLIT("{-singleDict-}"), ppr sty dname] \end{code} @@ -361,7 +359,7 @@ Parenthesize unless very simple: \begin{code} pprParendExpr :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> HsExpr tyvar uvar id pat -> Pretty + => PprStyle -> HsExpr tyvar uvar id pat -> Doc pprParendExpr sty expr = let @@ -377,7 +375,7 @@ pprParendExpr sty expr ExplicitTuple _ -> pp_as_was HsPar _ -> pp_as_was - _ -> ppParens pp_as_was + _ -> parens pp_as_was \end{code} %************************************************************************ @@ -389,15 +387,15 @@ pprParendExpr sty expr \begin{code} pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Pretty - -> HsRecordBinds tyvar uvar id pat -> Pretty + => PprStyle -> Doc + -> HsRecordBinds tyvar uvar id pat -> Doc pp_rbinds sty thing rbinds - = ppHang thing - 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds))) + = hang thing + 4 (braces (hsep (punctuate comma (map (pp_rbind sty) rbinds)))) where - pp_rbind PprForUser (v, _, True) = ppr PprForUser v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppChar '=', ppr sty e] + pp_rbind sty (v, _, True) | userStyle sty = ppr sty v + pp_rbind sty (v, e, _) = hsep [ppr sty v, char '=', ppr sty e] \end{code} %************************************************************************ @@ -410,10 +408,10 @@ pp_rbinds sty thing rbinds data DoOrListComp = DoStmt | ListComp pprDo DoStmt sty stmts - = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) + = hang (ptext SLIT("do")) 2 (vcat (map (ppr sty) stmts)) pprDo ListComp sty stmts - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) + = hang (hsep [lbrack, pprExpr sty expr, char '|']) + 4 (sep [interpp'SP sty quals, rbrack]) where ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps quals = init stmts @@ -440,16 +438,18 @@ data Stmt tyvar uvar id pat instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (Stmt tyvar uvar id pat) where - ppr sty (BindStmt pat expr _) - = ppCat [ppr sty pat, ppPStr SLIT("<-"), ppr sty expr] - ppr sty (LetStmt binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (ExprStmt expr _) - = ppr sty expr - ppr sty (GuardStmt expr _) - = ppr sty expr - ppr sty (ReturnStmt expr) - = ppCat [ppPStr SLIT("return"), ppr sty expr] + ppr sty stmt = pprQuote sty $ \ sty -> pprStmt sty stmt + +pprStmt sty (BindStmt pat expr _) + = hsep [ppr sty pat, ptext SLIT("<-"), ppr sty expr] +pprStmt sty (LetStmt binds) + = hsep [ptext SLIT("let"), ppr sty binds] +pprStmt sty (ExprStmt expr _) + = ppr sty expr +pprStmt sty (GuardStmt expr _) + = ppr sty expr +pprStmt sty (ReturnStmt expr) + = hsep [ptext SLIT("return"), ppr sty expr] \end{code} %************************************************************************ @@ -474,11 +474,11 @@ data ArithSeqInfo tyvar uvar id pat instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (ArithSeqInfo tyvar uvar id pat) where - ppr sty (From e1) = ppBesides [ppr sty e1, pp_dotdot] - ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot] - ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3] + ppr sty (From e1) = hcat [ppr sty e1, pp_dotdot] + ppr sty (FromThen e1 e2) = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot] + ppr sty (FromTo e1 e3) = hcat [ppr sty e1, pp_dotdot, ppr sty e3] ppr sty (FromThenTo e1 e2 e3) - = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3] + = hcat [ppr sty e1, comma, space, ppr sty e2, pp_dotdot, ppr sty e3] -pp_dotdot = ppPStr SLIT(" .. ") +pp_dotdot = ptext SLIT(" .. ") \end{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 0305911..03b62c7 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -10,11 +10,13 @@ module HsImpExp where IMP_Ubiq() -import Name ( pprNonSym ) import Outputable import PprStyle ( PprStyle(..) ) import Pretty import SrcLoc ( SrcLoc ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +#endif \end{code} %************************************************************************ @@ -36,20 +38,20 @@ data ImportDecl name \begin{code} instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where ppr sty (ImportDecl mod qual as spec _) - = ppHang (ppCat [ppPStr SLIT("import"), pp_qual qual, ppPStr mod, pp_as as]) + = hang (hsep [ptext SLIT("import"), pp_qual qual, ptext mod, pp_as as]) 4 (pp_spec spec) where - pp_qual False = ppNil - pp_qual True = ppPStr SLIT("qualified") + pp_qual False = empty + pp_qual True = ptext SLIT("qualified") - pp_as Nothing = ppNil - pp_as (Just a) = ppBeside (ppPStr SLIT("as ")) (ppPStr a) + pp_as Nothing = empty + pp_as (Just a) = (<>) (ptext SLIT("as ")) (ptext a) - pp_spec Nothing = ppNil + pp_spec Nothing = empty pp_spec (Just (False, spec)) - = ppParens (interpp'SP sty spec) + = parens (interpp'SP sty spec) pp_spec (Just (True, spec)) - = ppBeside (ppPStr SLIT("hiding ")) (ppParens (interpp'SP sty spec)) + = (<>) (ptext SLIT("hiding ")) (parens (interpp'SP sty spec)) \end{code} %************************************************************************ @@ -77,14 +79,14 @@ ieName (IEThingAll n) = n \begin{code} instance (NamedThing name, Outputable name) => Outputable (IE name) where - ppr sty (IEVar var) = pprNonSym sty var + ppr sty (IEVar var) = ppr sty var ppr sty (IEThingAbs thing) = ppr sty thing ppr sty (IEThingAll thing) - = ppBesides [ppr sty thing, ppStr "(..)"] + = hcat [ppr sty thing, text "(..)"] ppr sty (IEThingWith thing withs) - = ppBeside (ppr sty thing) - (ppParens (ppInterleave ppComma (map (pprNonSym sty) withs))) + = (<>) (ppr sty thing) + (parens (fsep (punctuate comma (map (ppr sty) withs)))) ppr sty (IEModuleContents mod) - = ppBeside (ppPStr SLIT("module ")) (ppPStr mod) + = (<>) (ptext SLIT("module ")) (ptext mod) \end{code} diff --git a/ghc/compiler/hsSyn/HsLoop.hs b/ghc/compiler/hsSyn/HsLoop.hs new file mode 100644 index 0000000..6a67984 --- /dev/null +++ b/ghc/compiler/hsSyn/HsLoop.hs @@ -0,0 +1,9 @@ +module HsLoop + + ( + module HsExpr, + module HsBinds + ) where + +import HsExpr +import HsBinds diff --git a/ghc/compiler/hsSyn/HsLoop.lhi b/ghc/compiler/hsSyn/HsLoop.lhi index 34b1926..1cdcbe3 100644 --- a/ghc/compiler/hsSyn/HsLoop.lhi +++ b/ghc/compiler/hsSyn/HsLoop.lhi @@ -2,26 +2,29 @@ interface HsLoop where -import HsExpr ( HsExpr ) -import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds ) +import HsExpr ( HsExpr, Stmt ) +import HsBinds ( HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds ) import HsDecls ( ConDecl ) import Name ( NamedThing ) import Outputable ( Outputable ) -- HsExpr outputs data HsExpr tyvar uvar id pat +data Stmt tyvar uvar id pat instance (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (HsExpr tyvar uvar id pat) +instance (NamedThing id, Outputable id, Outputable pat, + Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) + => Outputable (Stmt tyvar uvar id pat) + -- HsBinds outputs data Sig id instance (NamedThing name, Outputable name) => Outputable (Sig name) -data Bind tyvar uvar id pat - data HsBinds tyvar uvar id pat instance (Outputable pat, NamedThing id, Outputable id, diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 059db6a..ef370e3 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -12,12 +12,17 @@ module HsMatches where IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(HsLoop) ( HsExpr, nullBinds, HsBinds ) -import Outputable ( ifPprShowAll ) +IMPORT_DELOOPER(HsLoop) ( HsExpr, Stmt, nullBinds, HsBinds ) +import Outputable --( ifPprShowAll ) import PprType ( GenType{-instance Outputable-} ) import Pretty import SrcLoc ( SrcLoc{-instances-} ) import Util ( panic ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +import PprStyle +#endif + \end{code} %************************************************************************ @@ -70,7 +75,7 @@ data GRHSsAndBinds tyvar uvar id pat (GenType tyvar uvar) data GRHS tyvar uvar id pat - = GRHS (HsExpr tyvar uvar id pat) -- guard(ed)... + = GRHS [Stmt tyvar uvar id pat] -- guard(ed)... (HsExpr tyvar uvar id pat) -- ... right-hand side SrcLoc @@ -88,25 +93,25 @@ We know the list must have at least one @Match@ in it. \begin{code} pprMatches :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> (Bool, Pretty) -> [Match tyvar uvar id pat] -> Pretty + PprStyle -> (Bool, Doc) -> [Match tyvar uvar id pat] -> Doc pprMatches sty print_info@(is_case, name) [match] = if is_case then pprMatch sty is_case match else - ppHang name 4 (pprMatch sty is_case match) + hang name 4 (pprMatch sty is_case match) pprMatches sty print_info (match1 : rest) - = ppAbove (pprMatches sty print_info [match1]) + = ($$) (pprMatches sty print_info [match1]) (pprMatches sty print_info rest) --------------------------------------------- pprMatch :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - PprStyle -> Bool -> Match tyvar uvar id pat -> Pretty + PprStyle -> Bool -> Match tyvar uvar id pat -> Doc pprMatch sty is_case first_match - = ppHang (ppSep (map (ppr sty) row_of_pats)) + = hang (sep (map (ppr sty) row_of_pats)) 8 grhss_etc_stuff where (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match @@ -120,35 +125,39 @@ pprMatch sty is_case first_match = ([], pprGRHSsAndBinds sty is_case grhss_n_binds) ppr_match sty is_case (SimpleMatch expr) - = ([], ppHang (ppStr (if is_case then "->" else "=")) + = ([], hang (text (if is_case then "->" else "=")) 4 (ppr sty expr)) ---------------------------------------------------------- pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds) - = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) + = ($$) (vcat (map (pprGRHS sty is_case) grhss)) (if (nullBinds binds) - then ppNil - else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ]) + then empty + else vcat [ text "where", nest 4 (ppr sty binds) ]) pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty) - = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) + = ($$) (vcat (map (pprGRHS sty is_case) grhss)) (if (nullBinds binds) - then ppNil - else ppAboves [ ifPprShowAll sty - (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]), - ppStr "where", ppNest 4 (ppr sty binds) ]) + then empty + else vcat [ ifPprShowAll sty + (hsep [text "{- ty:", ppr sty ty, text "-}"]), + text "where", nest 4 (ppr sty binds) ]) --------------------------------------------- pprGRHS :: (NamedThing id, Outputable id, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Pretty + => PprStyle -> Bool -> GRHS tyvar uvar id pat -> Doc + +pprGRHS sty is_case (GRHS [] expr locn) + = hang (text (if is_case then "->" else "=")) + 4 (ppr sty expr) pprGRHS sty is_case (GRHS guard expr locn) - = ppHang (ppCat [ppChar '|', ppr sty guard, ppStr (if is_case then "->" else "=")]) + = hang (hsep [char '|', ppr sty guard, text (if is_case then "->" else "=")]) 4 (ppr sty expr) pprGRHS sty is_case (OtherwiseGRHS expr locn) - = ppHang (ppStr (if is_case then "->" else "=")) + = hang (text (if is_case then "->" else "=")) 4 (ppr sty expr) \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index aff6762..f7bc4e0 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -21,17 +21,21 @@ IMP_Ubiq() -- friends: import HsBasic ( HsLit, Fixity ) +IMPORT_DELOOPER(IdLoop) IMPORT_DELOOPER(HsLoop) ( HsExpr ) + -- others: -import Id ( dataConTyCon, GenId ) +import Id --( dataConTyCon, GenId ) import Maybes ( maybeToBool ) -import Name ( pprSym, pprNonSym ) -import Outputable ( interppSP, interpp'SP, ifPprShowAll ) -import PprStyle ( PprStyle(..) ) +import Outputable --( interppSP, interpp'SP, ifPprShowAll ) +import PprStyle ( PprStyle(..), userStyle ) import Pretty import TyCon ( maybeTyConSingleCon ) import PprType ( GenType ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +#endif \end{code} Patterns come in distinct before- and after-typechecking flavo(u)rs. @@ -125,23 +129,23 @@ data OutPat tyvar uvar id instance (Outputable name, NamedThing name) => Outputable (InPat name) where ppr = pprInPat -pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty +pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Doc -pprInPat sty (WildPatIn) = ppChar '_' +pprInPat sty (WildPatIn) = char '_' pprInPat sty (VarPatIn var) = ppr sty var pprInPat sty (LitPatIn s) = ppr sty s -pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) +pprInPat sty (LazyPatIn pat) = (<>) (char '~') (ppr sty pat) pprInPat sty (AsPatIn name pat) - = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] + = parens (hcat [ppr sty name, char '@', ppr sty pat]) pprInPat sty (ConPatIn c pats) = if null pats then ppr sty c else - ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens + hsep [ppr sty c, interppSP sty pats] -- ParPats put in the parens pprInPat sty (ConOpPatIn pat1 op fixity pat2) - = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens + = hsep [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) @@ -150,27 +154,27 @@ pprInPat sty (NegPatIn pat) = let pp_pat = pprInPat sty pat in - ppBeside (ppChar '-') ( + (<>) (char '-') ( case pat of LitPatIn _ -> pp_pat - _ -> ppParens pp_pat + _ -> parens pp_pat ) pprInPat sty (ParPatIn pat) - = ppParens (pprInPat sty pat) + = parens (pprInPat sty pat) pprInPat sty (ListPatIn pats) - = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] + = brackets (interpp'SP sty pats) pprInPat sty (TuplePatIn pats) - = ppParens (interpp'SP sty pats) + = parens (interpp'SP sty pats) pprInPat sty (NPlusKPatIn n k) - = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] + = parens (hcat [ppr sty n, char '+', ppr sty k]) pprInPat sty (RecPatIn con rpats) - = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] + = hsep [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))] where - pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] + pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v + pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p] \end{code} \begin{code} @@ -180,47 +184,46 @@ instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id) \end{code} \begin{code} -pprOutPat sty (WildPat ty) = ppChar '_' +pprOutPat sty (WildPat ty) = char '_' pprOutPat sty (VarPat var) = ppr sty var -pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] +pprOutPat sty (LazyPat pat) = hcat [char '~', ppr sty pat] pprOutPat sty (AsPat name pat) - = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] + = parens (hcat [ppr sty name, char '@', ppr sty pat]) pprOutPat sty (ConPat name ty []) - = ppBeside (ppr sty name) + = (<>) (ppr sty name) (ifPprShowAll sty (pprConPatTy sty ty)) pprOutPat sty (ConPat name ty pats) - = ppBesides [ppLparen, ppr sty name, ppSP, - interppSP sty pats, ppRparen, - ifPprShowAll sty (pprConPatTy sty ty) ] + = hcat [parens (hcat [ppr sty name, space, interppSP sty pats]), + ifPprShowAll sty (pprConPatTy sty ty) ] pprOutPat sty (ConOpPat pat1 op pat2 ty) - = ppBesides [ppLparen, ppr sty pat1, ppSP, pprSym sty op, ppSP, ppr sty pat2, ppRparen] + = parens (hcat [ppr sty pat1, space, ppr sty op, space, ppr sty pat2]) pprOutPat sty (ListPat ty pats) - = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] + = brackets (interpp'SP sty pats) pprOutPat sty (TuplePat pats) - = ppParens (interpp'SP sty pats) + = parens (interpp'SP sty pats) pprOutPat sty (RecPat con ty rpats) - = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))] + = hcat [ppr sty con, braces (hsep (punctuate comma (map (pp_rpat sty) rpats)))] where - pp_rpat PprForUser (v, _, True) = ppr PprForUser v - pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppChar '=', ppr sty p] + pp_rpat sty (v, _, True) | userStyle sty = ppr PprForUser v + pp_rpat sty (v, p, _) = hsep [ppr sty v, char '=', ppr sty p] pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more pprOutPat sty (NPlusKPat n k ty e1 e2) -- ToDo: print more - = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] + = parens (hcat [ppr sty n, char '+', ppr sty k]) pprOutPat sty (DictPat dicts methods) - = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], - ppBracket (interpp'SP sty dicts), - ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] + = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP sty dicts), + brackets (interpp'SP sty methods)]) pprConPatTy sty ty - = ppParens (ppr sty ty) + = parens (ppr sty ty) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index c8a7112..26075b3 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -53,16 +53,16 @@ noClassOpPragmas = NoClassOpPragmas isNoClassOpPragmas NoClassOpPragmas = True instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = ppNil + ppr sty NoClassPragmas = empty instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = ppNil + ppr sty NoClassOpPragmas = empty instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = ppNil + ppr sty NoInstancePragmas = empty instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = ppNil + ppr sty NoGenPragmas = empty \end{code} ========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ============== @@ -171,69 +171,69 @@ isNoInstancePragmas _ = False Some instances for printing (just for debugging, really) \begin{code} instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = ppNil + ppr sty NoClassPragmas = empty ppr sty (SuperDictPragmas sdsel_prags) - = ppAbove (ppPStr SLIT("{-superdict pragmas-}")) + = ($$) (ptext SLIT("{-superdict pragmas-}")) (ppr sty sdsel_prags) instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = ppNil + ppr sty NoClassOpPragmas = empty ppr sty (ClassOpPragmas op_prags defm_prags) - = ppAbove (ppCat [ppPStr SLIT("{-meth-}"), ppr sty op_prags]) - (ppCat [ppPStr SLIT("{-defm-}"), ppr sty defm_prags]) + = ($$) (hsep [ptext SLIT("{-meth-}"), ppr sty op_prags]) + (hsep [ptext SLIT("{-defm-}"), ppr sty defm_prags]) instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = ppNil + ppr sty NoInstancePragmas = empty ppr sty (SimpleInstancePragma dfun_pragmas) - = ppCat [ppPStr SLIT("{-dfun-}"), ppr sty dfun_pragmas] + = hsep [ptext SLIT("{-dfun-}"), ppr sty dfun_pragmas] ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) - = ppAbove (ppCat [ppPStr SLIT("{-constm-}"), ppr sty dfun_pragmas]) - (ppAboves (map pp_pair name_pragma_pairs)) + = ($$) (hsep [ptext SLIT("{-constm-}"), ppr sty dfun_pragmas]) + (vcat (map pp_pair name_pragma_pairs)) where pp_pair (n, prags) - = ppCat [ppr sty n, ppEquals, ppr sty prags] + = hsep [ppr sty n, equals, ppr sty prags] ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) - = ppAbove (ppCat [ppPStr SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) - (ppAboves (map pp_info spec_pragma_info)) + = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) + (vcat (map pp_info spec_pragma_info)) where pp_info (ty_maybes, num_dicts, prags) - = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack, - ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags] - pp_ty Nothing = ppPStr SLIT("_N_") + = hcat [brackets (hsep (map pp_ty ty_maybes)), + parens (int num_dicts), equals, ppr sty prags] + pp_ty Nothing = ptext SLIT("_N_") pp_ty (Just t)= ppr sty t instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = ppNil + ppr sty NoGenPragmas = empty ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs) - = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def? + = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def? pp_str strictness, pp_unf unfolding, pp_specs specs] where - pp_arity Nothing = ppNil - pp_arity (Just i) = ppBeside (ppPStr SLIT("ARITY=")) (ppInt i) + pp_arity Nothing = empty + pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i) - pp_upd Nothing = ppNil + pp_upd Nothing = empty pp_upd (Just u) = ppUpdateInfo sty u - pp_str NoImpStrictness = ppNil + pp_str NoImpStrictness = empty pp_str (ImpStrictness is_bot demands wrkr_prags) - = ppBesides [ppPStr SLIT("IS_BOT="), ppr sty is_bot, - ppPStr SLIT("STRICTNESS="), ppStr (showList demands ""), - ppPStr SLIT(" {"), ppr sty wrkr_prags, ppChar '}'] + = hcat [ptext SLIT("IS_BOT="), ppr sty is_bot, + ptext SLIT("STRICTNESS="), text (showList demands ""), + ptext SLIT(" {"), ppr sty wrkr_prags, char '}'] - pp_unf NoImpUnfolding = ppPStr SLIT("NO_UNFOLDING") - pp_unf (ImpMagicUnfolding m) = ppBeside (ppPStr SLIT("MAGIC=")) (ppPStr m) - pp_unf (ImpUnfolding g core) = ppBeside (ppPStr SLIT("UNFOLD=")) (ppr sty core) + pp_unf NoImpUnfolding = ptext SLIT("NO_UNFOLDING") + pp_unf (ImpMagicUnfolding m) = (<>) (ptext SLIT("MAGIC=")) (ptext m) + pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr sty core) - pp_specs [] = ppNil + pp_specs [] = empty pp_specs specs - = ppBesides [ppPStr SLIT("SPECS=["), ppInterleave ppSP (map pp_spec specs), ppChar ']'] + = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']'] where pp_spec (ty_maybes, num_dicts, gprags) - = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags] + = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr sty gprags] - pp_MaB Nothing = ppPStr SLIT("_N_") + pp_MaB Nothing = ptext SLIT("_N_") pp_MaB (Just x) = ppr sty x \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 2702f8a..0647ba2 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -23,7 +23,8 @@ module HsSyn ( EXP_MODULE(HsBasic) , EXP_MODULE(HsMatches) , EXP_MODULE(HsPat) , - EXP_MODULE(HsTypes) + EXP_MODULE(HsTypes), + NewOrData(..) ) where IMP_Ubiq() @@ -33,7 +34,7 @@ import HsBinds import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), DefaultDecl(..), FixityDecl(..), - ConDecl(..), BangType(..), + ConDecl(..), ConDetails(..), BangType(..), IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..), hsDeclName ) @@ -46,12 +47,16 @@ import HsTypes import HsPragmas ( ClassPragmas, ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas ) import HsCore +import TyCon ( NewOrData(..) ) -- others: import FiniteMap ( FiniteMap ) import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) ) import Pretty import SrcLoc ( SrcLoc ) +#if __GLASGOW_HASKELL__ >= 202 +import Name +#endif \end{code} @Fake@ is a placeholder type; for when tyvars and uvars aren't used. @@ -86,24 +91,24 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (HsModule name iface_version exports imports fixities decls src_loc) - = ppAboves [ + = vcat [ ifPprShowAll sty (ppr sty src_loc), ifnotPprForUser sty (pp_iface_version iface_version), case exports of - Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")] - Just es -> ppAboves [ - ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen], - ppNest 8 (interpp'SP sty es), - ppNest 4 (ppPStr SLIT(") where")) + Nothing -> hsep [ptext SLIT("module"), ptext name, ptext SLIT("where")] + Just es -> vcat [ + hsep [ptext SLIT("module"), ptext name, lparen], + nest 8 (interpp'SP sty es), + nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, pp_nonnull fixities, pp_nonnull decls ] where - pp_nonnull [] = ppNil - pp_nonnull xs = ppAboves (map (ppr sty) xs) + pp_nonnull [] = empty + pp_nonnull xs = vcat (map (ppr sty) xs) - pp_iface_version Nothing = ppNil - pp_iface_version (Just n) = ppCat [ppStr "{-# INTERFACE", ppInt n, ppStr "#-}"] + pp_iface_version Nothing = empty + pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"] \end{code} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 195809d..bb087d5 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -23,7 +23,7 @@ module HsTypes ( IMP_Ubiq() -import Outputable ( interppSP, ifnotPprForUser ) +import Outputable --( interppSP, ifnotPprForUser ) import Kind ( Kind {- instance Outputable -} ) import Name ( nameOccName ) import Pretty @@ -104,7 +104,7 @@ instance (Outputable name) => Outputable (HsType name) where instance (Outputable name) => Outputable (HsTyVar name) where ppr sty (UserTyVar name) = ppr_hs_tyname sty name - ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind] + ppr sty (IfaceTyVar name kind) = hsep [ppr_hs_tyname sty name, ptext SLIT("::"), ppr sty kind] -- Here comes a rather gross hack. @@ -118,16 +118,17 @@ ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name ppr_forall sty ctxt_prec [] [] ty = ppr_mono_ty sty ctxt_prec ty ppr_forall sty ctxt_prec tvs ctxt ty - = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppPStr SLIT("=>"), + = maybeParen (ctxt_prec >= pREC_FUN) $ + sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs), + pprContext sty ctxt, ptext SLIT("=>"), pprHsType sty ty] -pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty -pprContext sty [] = ppNil +pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc +pprContext sty [] = empty pprContext sty context - = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))] + = hsep [braces (hsep (punctuate comma (map ppr_assert context)))] where - ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty] + ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty] \end{code} \begin{code} @@ -135,13 +136,13 @@ pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) -maybeParen :: Bool -> Pretty -> Pretty -maybeParen True p = ppParens p +maybeParen :: Bool -> Doc -> Doc +maybeParen True p = parens p maybeParen False p = p -- printing works more-or-less as for Types -pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty +pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Doc pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty @@ -156,20 +157,20 @@ ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) p2 = ppr_mono_ty sty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) - (ppSep [p1, ppBeside (ppPStr SLIT("-> ")) p2]) + (sep [p1, (<>) (ptext SLIT("-> ")) p2]) ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = ppParens (ppInterleave ppComma (map (ppr sty) tys)) + = parens (sep (punctuate comma (map (ppr sty) tys))) ppr_mono_ty sty ctxt_prec (MonoListTy _ ty) - = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] + = brackets (ppr_mono_ty sty pREC_TOP ty) ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty) = maybeParen (ctxt_prec >= pREC_CON) - (ppCat [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty]) + (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty]) ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) - = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty]) + = braces (hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]) -- Curlies are temporary \end{code} @@ -186,8 +187,8 @@ wrong}, so be careful! \begin{code} cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_ -cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ -cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ +--cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ +--cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 19e3d26..cae8da7 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -58,8 +58,6 @@ module CmdLineOpts ( opt_GranMacros, opt_Haskell_1_3, opt_HiMap, - opt_HiSuffix, - opt_HiSuffixPrelude, opt_IgnoreIfacePragmas, opt_IgnoreStrictnessPragmas, opt_IrrefutableEverything, @@ -98,12 +96,19 @@ module CmdLineOpts ( opt_Verbose, opt_WarnNameShadowing, - opt_NoWarnIncompletePatterns - + opt_WarnUnusedNames, + opt_WarnIncompletePatterns, + opt_TyConPruning ) where IMPORT_1_3(Array(array, (//))) +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 import PreludeGlaST -- bad bad bad boy, Will (_Array internals) +#else +import GlaExts +import ArrBase +import PrelBase (Lift(..)) +#endif import Argv CHK_Ubiq() -- debugging consistency check @@ -224,6 +229,10 @@ data SimplifierSwitch -- (Sigh, what a HACK, Andy. WDP 96/01) | SimplCaseMerge + | SimplCaseScrutinee -- This flag tells that the expression being simplified is + -- the scrutinee of a case expression, so we should + -- apply the scrutinee discount when considering inlinings. + -- See SimplVar.lhs \end{code} %************************************************************************ @@ -273,7 +282,7 @@ opt_D_dump_rdr = lookUp SLIT("-ddump-rdr") opt_D_dump_realC = lookUp SLIT("-ddump-realC") opt_D_dump_rn = lookUp SLIT("-ddump-rn") opt_D_dump_simpl = lookUp SLIT("-ddump-simpl") -opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl_iterations") +opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl-iterations") opt_D_dump_spec = lookUp SLIT("-ddump-spec") opt_D_dump_stg = lookUp SLIT("-ddump-stg") opt_D_dump_stranal = lookUp SLIT("-ddump-stranal") @@ -297,8 +306,6 @@ opt_GranMacros = lookUp SLIT("-fgransim") opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files -opt_HiSuffix = lookup_str "-hisuf=" -opt_HiSuffixPrelude = lookup_str "-hisuf-prelude=" opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") @@ -337,7 +344,9 @@ opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDIN opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") -opt_NoWarnIncompletePatterns = lookUp SLIT("-fno-warn-incomplete-patterns") +opt_WarnIncompletePatterns = not (lookUp SLIT("-fno-warn-incomplete-patterns")) +opt_WarnUnusedNames = lookUp SLIT("-fwarn-unused-names") +opt_TyConPruning = not (lookUp SLIT("-fno-tycon-pruning")) -- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" -- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" @@ -496,11 +505,13 @@ tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28) tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29) tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(30) tagOf_SimplSwitch SimplCaseMerge = ILIT(31) +tagOf_SimplSwitch SimplCaseScrutinee = ILIT(32) + -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too! tagOf_SimplSwitch _ = panic# "tagOf_SimplSwitch" -lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseMerge) +lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseScrutinee) \end{code} %************************************************************************ @@ -510,11 +521,16 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplCaseMerge) %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 # define ARRAY Array # define LIFT GHCbase.Lift # define SET_TO =: (=:) a b = (a,b) +#elif __GLASGOW_HASKELL__ >= 202 +# define ARRAY Array +# define LIFT Lift +# define SET_TO =: +(=:) a b = (a,b) #else # define ARRAY _Array # define LIFT _Lift diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 5918cf6..aba852b 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -17,43 +17,46 @@ module ErrUtils ( IMP_Ubiq(){-uitous-} -import Bag ( bagToList ) +import Bag --( bagToList ) import PprStyle ( PprStyle(..) ) import Pretty import SrcLoc ( noSrcLoc, SrcLoc{-instance-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} \begin{code} -type Error = PprStyle -> Pretty -type Warning = PprStyle -> Pretty -type Message = PprStyle -> Pretty +type Error = PprStyle -> Doc +type Warning = PprStyle -> Doc +type Message = PprStyle -> Doc addErrLoc :: SrcLoc -> String -> Error -> Error addErrLoc locn title rest_of_err_msg sty - = ppHang (ppBesides [ppr PprForUser locn, - if null title then ppNil else ppStr (": " ++ title), - ppChar ':']) + = hang (hcat [ppr PprForUser locn, + if null title then empty else text (": " ++ title), + char ':']) 4 (rest_of_err_msg sty) addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error addShortErrLocLine locn rest_of_err_msg sty - = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':')) + = hang ((<>) (ppr PprForUser locn) (char ':')) 4 (rest_of_err_msg sty) addShortWarnLocLine locn rest_of_err_msg sty - = ppHang (ppBeside (ppr PprForUser locn) (ppPStr SLIT(":warning:"))) + = hang ((<>) (ppr PprForUser locn) (ptext SLIT(":warning:"))) 4 (rest_of_err_msg sty) dontAddErrLoc :: String -> Error -> Error dontAddErrLoc title rest_of_err_msg sty - = ppHang (ppBesides [ppStr title, ppChar ':']) + = hang (hcat [text title, char ':']) 4 (rest_of_err_msg sty) -pprBagOfErrors :: PprStyle -> Bag Error -> Pretty +pprBagOfErrors :: PprStyle -> Bag Error -> Doc pprBagOfErrors sty bag_of_errors = let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in - ppAboves (map (\ p -> ppAbove ppSP p) pretties) + vcat (map (\ p -> ($$) space p) pretties) \end{code} \begin{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 9db06ac..b81182c 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -20,7 +20,11 @@ import RnMonad ( ExportEnv ) import MkIface -- several functions import TcModule ( typecheckModule ) -import Desugar ( deSugar, DsMatchContext, pprDsWarnings, DsWarnFlavour {-TEMP!-} ) +import Desugar ( deSugar, pprDsWarnings +#if __GLASGOW_HASKELL__ <= 200 + , DsMatchContext, DsWarnFlavour +#endif + ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) import StgSyn ( collectFinalStgBinders ) @@ -53,6 +57,9 @@ import Name ( Name ) -- instances import PprType ( GenType, GenTyVar ) -- instances import TyVar ( GenTyVar ) -- instances import Unique ( Unique ) -- instances +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif \end{code} \begin{code} @@ -69,7 +76,7 @@ main = doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.02, for Haskell 1.3" "" >> + = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.03, for Haskell 1.4" "" >> -- ******* READER show_pass "Reader" >> @@ -145,15 +152,15 @@ doIt (core_cmds, stg_cmds) input_pgm case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - local_tycons, inst_info, pragma_tycon_specs, + local_tycons, local_classes, inst_info, pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" - (pp_show (ppAboves [ + (pp_show (vcat [ ppr pprStyle recsel_binds, ppr pprStyle class_binds, ppr pprStyle inst_binds, - ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds), + ppr pprStyle const_binds, ppr pprStyle val_binds])) >> doDump opt_D_dump_deriv "Derived instances:" @@ -169,11 +176,11 @@ doIt (core_cmds, stg_cmds) input_pgm (if isEmptyBag ds_warnings then return () else - hPutStr stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) + hPutStr stderr (pp_show (pprDsWarnings pprErrorsStyle ds_warnings)) >> hPutStr stderr "\n" ) >> - doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves + doDump opt_D_dump_ds "Desugared:" (pp_show (vcat (map (pprCoreBinding pprStyle) desugared))) >> @@ -190,7 +197,7 @@ doIt (core_cmds, stg_cmds) input_pgm \ (simplified, SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) -> - doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves + doDump opt_D_dump_simpl "Simplified:" (pp_show (vcat (map (pprCoreBinding pprStyle) simplified))) >> @@ -209,7 +216,7 @@ doIt (core_cmds, stg_cmds) input_pgm \ (stg_binds2, cost_centre_info) -> doDump opt_D_dump_stg "STG syntax:" - (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) + (pp_show (vcat (map (pprPlainStgBinding pprStyle) stg_binds2))) >> -- Dump instance decls and type signatures into the interface file @@ -217,7 +224,7 @@ doIt (core_cmds, stg_cmds) input_pgm final_ids = collectFinalStgBinders stg_binds2 in _scc_ "Interface" - ifaceDecls if_handle rn_mod inst_info final_ids simplified >> + ifaceDecls if_handle local_tycons local_classes inst_info final_ids simplified >> endIface if_handle >> -- We are definitely done w/ interface-file stuff at this point: -- (See comments near call to "startIface".) @@ -242,6 +249,7 @@ doIt (core_cmds, stg_cmds) input_pgm doDump opt_D_dump_flatC "Flat Abstract C:" (dumpRealC flat_abstractC) >> + _scc_ "CodeOutput" -- You can have C (c_output) or assembly-language (ncg_output), -- but not both. [Allowing for both gives a space leak on -- flat_abstractC. WDP 94/10] @@ -297,7 +305,8 @@ doIt (core_cmds, stg_cmds) input_pgm doDump switch hdr string = if switch - then hPutStr stderr hdr >> + then hPutStr stderr ("\n\n" ++ (take 80 $ repeat '=')) >> + hPutStr stderr ('\n': hdr) >> hPutStr stderr ('\n': string) >> hPutStr stderr "\n" else return () @@ -308,28 +317,28 @@ pprCols = (80 :: Int) -- could make configurable (pprStyle, pprErrorsStyle) | opt_PprStyle_All = (PprShowAll, PprShowAll) | opt_PprStyle_Debug = (PprDebug, PprDebug) - | opt_PprStyle_User = (PprForUser, PprForUser) - | otherwise = (PprDebug, PprForUser) + | opt_PprStyle_User = (PprQuote, PprQuote) + | otherwise = (PprDebug, PprQuote) -pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p +pp_show p = show p -- ToDo: use pprCols checkErrors errs_bag warns_bag | not (isEmptyBag errs_bag) - = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle errs_bag)) + = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle errs_bag)) >> hPutStr stderr "\n" >> - hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) + hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag)) >> hPutStr stderr "\n" >> ghcExit 1 | not (isEmptyBag warns_bag) - = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) >> + = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag)) >> hPutStr stderr "\n" | otherwise = return () ppSourceStats (HsModule name version exports imports fixities decls src_loc) - = ppAboves (map pp_val + = vcat (map pp_val [("ExportAll ", export_all), -- 1 if no export list ("ExportDecls ", export_ds), ("ExportModules ", export_ms), @@ -362,13 +371,13 @@ ppSourceStats (HsModule name version exports imports fixities decls src_loc) ("SpecialisedBinds ", bind_specs) ]) where - pp_val (str, 0) = ppNil - pp_val (str, n) = ppBesides [ppStr str, ppInt n] + pp_val (str, 0) = empty + pp_val (str, n) = hcat [text str, int n] fixity_ds = length fixities type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls] - data_decls = [d | TyD d@(TyData _ _ _ _ _ _ _) <- decls] - newt_decls = [d | TyD d@(TyNew _ _ _ _ _ _ _) <- decls] + data_decls = [d | TyD d@(TyData DataType _ _ _ _ _ _ _) <- decls] + newt_decls = [d | TyD d@(TyData NewType _ _ _ _ _ _ _) <- decls] type_ds = length type_decls data_ds = length data_decls newt_ds = length newt_decls @@ -400,14 +409,8 @@ ppSourceStats (HsModule name version exports imports fixities decls src_loc) count_binds EmptyBinds = (0,0,0,0,0) count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2 - count_binds (SingleBind b) = case count_bind b of - (vs,fs) -> (vs,fs,0,0,0) - count_binds (BindWith b sigs) = case (count_bind b, count_sigs sigs) of - ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is) - - count_bind EmptyBind = (0,0) - count_bind (NonRecBind b) = count_monobinds b - count_bind (RecBind b) = count_monobinds b + count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of + ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is) count_monobinds EmptyMonoBinds = (0,0) count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 @@ -433,10 +436,8 @@ ppSourceStats (HsModule name version exports imports fixities decls src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData _ _ _ constrs derivs _ _) + data_info (TyData _ _ _ _ constrs derivs _ _) = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) - data_info (TyNew _ _ _ constr derivs _ _) - = (1, case derivs of {Nothing -> 0; Just ds -> length ds}) class_info (ClassDecl _ _ _ meth_sigs def_meths _ _) = case count_sigs meth_sigs of diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 15bb569..d88568d 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -25,27 +25,32 @@ import TcInstUtil ( InstInfo(..) ) import CmdLineOpts import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon, - getIdInfo, idWantsToBeINLINEd, omitIfaceSigForId, + getIdInfo, getInlinePragma, omitIfaceSigForId, dataConStrictMarks, StrictnessMark(..), SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, - GenId{-instance NamedThing/Outputable-} + GenId{-instance NamedThing/Outputable-}, SYN_IE(Id) + ) -import IdInfo ( StrictnessInfo, ArityInfo, Unfolding, +import IdInfo ( StrictnessInfo, ArityInfo, arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, - getWorkerId_maybe, bottomIsGuaranteed + getWorkerId_maybe, bottomIsGuaranteed, IdInfo ) import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) ) -import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) ) +import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding ) import FreeVars ( addExprFVs ) import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName, - OccName, occNameString, nameOccName, nameString, isExported, pprNonSym, - Name {-instance NamedThing-}, Provenance + OccName, occNameString, nameOccName, nameString, isExported, + Name {-instance NamedThing-}, Provenance, NamedThing(..) ) -import TyCon ( TyCon{-instance NamedThing-} ) -import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType ) -import FieldLabel ( FieldLabel{-instance NamedThing-} ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) +import TyCon ( TyCon(..) {-instance NamedThing-} ) +import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), GenClassOp, + classOpLocalType, classSig ) +import FieldLabel ( FieldLabel{-instance NamedThing-}, + fieldLabelName, fieldLabelType ) +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy, + mkTyVarTy, SYN_IE(Type) + ) import TyVar ( GenTyVar {- instance Eq -} ) import Unique ( Unique {- instance Eq -} ) @@ -54,15 +59,18 @@ import PprStyle ( PprStyle(..) ) import PprType import PprCore ( pprIfaceUnfolding ) import Pretty -import Unpretty -- ditto +import Outputable ( printDoc ) -import Bag ( bagToList ) +import Bag ( bagToList, isEmptyBag ) import Maybes ( catMaybes, maybeToBool ) import FiniteMap ( emptyFM, addToFM, addToFM_C, lookupFM, fmToList, eltsFM, FiniteMap ) import UniqFM ( UniqFM, lookupUFM, listToUFM ) import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL, - assertPanic, panic{-ToDo:rm-}, pprTrace ) + assertPanic, panic{-ToDo:rm-}, pprTrace, + pprPanic + ) +import Outputable ( Outputable(..) ) \end{code} @@ -84,7 +92,7 @@ ifaceMain :: Maybe Handle ifaceDecls :: Maybe Handle - -> RenamedHsModule + -> [TyCon] -> [Class] -> Bag InstInfo -> [Id] -- Ids used at code-gen time; they have better pragma info! -> [CoreBinding] -- In dependency order, later depend on earlier @@ -118,19 +126,25 @@ ifaceMain (Just if_hdl) ifaceFixities if_hdl fixities >> return () -ifaceDecls Nothing rn_mod inst_info final_ids simplified = return () +ifaceDecls Nothing tycons classes inst_info final_ids simplified = return () ifaceDecls (Just hdl) - (HsModule _ _ _ _ _ decls _) + tycons classes inst_infos final_ids binds - | null decls = return () + | null_decls = return () -- You could have a module with just (re-)exports/instances in it | otherwise = ifaceInstances hdl inst_infos >>= \ needed_ids -> hPutStr hdl "_declarations_\n" >> - ifaceTCDecls hdl decls >> + ifaceClasses hdl classes >> + ifaceTyCons hdl tycons >> ifaceBinds hdl needed_ids final_ids binds >> return () + where + null_decls = null binds && + null tycons && + null classes && + isEmptyBag inst_infos \end{code} \begin{code} @@ -139,18 +153,18 @@ ifaceUsages if_hdl import_usages hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where upp_uses (m, mv, versions) - = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "), - upp_import_versions (sort_versions versions), uppSemi] + = hcat [upp_module m, space, int mv, ptext SLIT(" :: "), + upp_import_versions (sort_versions versions), semi] -- For imported versions we do print the version number upp_import_versions nvs - = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ] + = hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- nvs ] ifaceInstanceModules if_hdl [] = return () ifaceInstanceModules if_hdl imods = hPutStr if_hdl "_instance_modules_\n" >> - hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >> + printDoc OneLineMode if_hdl (hsep (map ptext (sortLt (<) imods))) >> hPutStr if_hdl "\n" ifaceExports if_hdl [] = return () @@ -169,27 +183,14 @@ ifaceExports if_hdl avails -- Print one module's worth of stuff do_one_module (mod_name, avails) - = uppBesides [upp_module mod_name, uppSP, - uppCat (map upp_avail (sortLt lt_avail avails)), - uppSemi] + = hcat [upp_module mod_name, space, + hsep (map upp_avail (sortLt lt_avail avails)), + semi] ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities = hPutStr if_hdl "_fixities_\n" >> hPutCol if_hdl upp_fixity fixities - -ifaceTCDecls if_hdl decls - = hPutCol if_hdl ppr_decl tc_decls_for_iface - where - tc_decls_for_iface = sortLt lt_decl (filter for_iface decls) - for_iface decl@(ClD _) = for_iface_name (hsDeclName decl) - for_iface decl@(TyD _) = for_iface_name (hsDeclName decl) - for_iface other_decl = False - - for_iface_name name = isLocallyDefined name && - not (isWiredInName name) - - lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2 \end{code} %************************************************************************ @@ -224,8 +225,8 @@ ifaceInstances if_hdl inst_infos forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) renumbered_ty = renumber_ty forall_ty in - uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, - uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi] + hcat [ptext SLIT("instance "), ppr_ty renumbered_ty, + ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] \end{code} @@ -245,7 +246,7 @@ ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added -> Bool -- True <=> recursive, so don't print unfolding -> Id -> CoreExpr -- The Id's right hand side - -> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids + -> Maybe (Doc, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids ifaceId get_idinfo needed_ids is_rec id rhs | not (id `elementOfIdSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] @@ -253,18 +254,18 @@ ifaceId get_idinfo needed_ids is_rec id rhs = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs - = Just (ppCat [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids) + = Just (hsep [sig_pretty, pp_double_semi, prag_pretty], new_needed_ids) where - pp_double_semi = ppPStr SLIT(";;") + pp_double_semi = ptext SLIT(";;") idinfo = get_idinfo id - inline_pragma = idWantsToBeINLINEd id + inline_pragma = getInlinePragma id ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) - sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" _:_ "), ty_pretty] + sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty] prag_pretty - | opt_OmitInterfacePragmas = ppNil - | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi] + | opt_OmitInterfacePragmas = empty + | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi] ------------ Arity -------------- arity_pretty = ppArityInfo PprInterface (arityInfo idinfo) @@ -275,18 +276,17 @@ ifaceId get_idinfo needed_ids is_rec id rhs strict_pretty = ppStrictnessInfo PprInterface strict_info ------------ Unfolding -------------- - unfold_pretty | show_unfold = ppCat [ppPStr SLIT("_U_"), pprIfaceUnfolding rhs] - | otherwise = ppNil + unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs] + | otherwise = empty - show_unfold = not implicit_unfolding && -- Unnecessary - (inline_pragma || not dodgy_unfolding) -- Dangerous + show_unfold = not implicit_unfolding && -- Not unnecessary + not dodgy_unfolding -- Not dangerous implicit_unfolding = maybeToBool maybe_worker || bottomIsGuaranteed strict_info - dodgy_unfolding = is_rec || -- No recursive unfoldings please! - case guidance of -- Too big to show - UnfoldNever -> True + dodgy_unfolding = case guidance of -- True <=> too big to show, or the Inline pragma + UnfoldNever -> True -- says it shouldn't be inlined other -> False guidance = calcUnfoldingGuidance inline_pragma @@ -323,7 +323,7 @@ ifaceBinds :: Handle -> IO () ifaceBinds hdl needed_ids final_ids binds - = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >> + = mapIO (printDoc OneLineMode hdl) pretties >> hPutStr hdl "\n" where final_id_map = listToUFM [(id,id) | id <- final_ids] @@ -336,7 +336,7 @@ ifaceBinds hdl needed_ids final_ids binds -- provoke earlier ones to be emitted go needed [] = if not (isEmptyIdSet needed) then pprTrace "ifaceBinds: free vars:" - (ppSep (map (ppr PprDebug) (idSetToList needed))) $ + (sep (map (ppr PprDebug) (idSetToList needed))) $ [] else [] @@ -356,7 +356,7 @@ ifaceBinds hdl needed_ids final_ids binds needed'' = needed' `minusIdSet` mkIdSet (map fst pairs) -- Later ones may spuriously cause earlier ones to be "needed" again - go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty]) + go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Doc]) go_rec needed pairs | null pretties = (needed, []) | otherwise = (final_needed, more_pretties ++ pretties) @@ -378,52 +378,159 @@ ifaceBinds hdl needed_ids final_ids binds %* * %************************************************************************ +\begin{code} +ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons )) +ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes)) + +for_iface_name name = isLocallyDefined name && + not (isWiredInName name) + +upp_tycon tycon = ifaceTyCon PprInterface tycon +upp_class clas = ifaceClass PprInterface clas +\end{code} + + +\begin{code} +ifaceTyCon :: PprStyle -> TyCon -> Doc +ifaceTyCon sty tycon + = case tycon of + DataTyCon uniq name kind tyvars theta data_cons deriv new_or_data + -> hsep [ ptext (keyword new_or_data), + ppr_decl_context sty theta, + ppr sty name, + hsep (map (pprTyVarBndr sty) tyvars), + ptext SLIT("="), + hsep (punctuate (ptext SLIT(" | ")) (map ppr_con data_cons)), + semi + ] + + SynTyCon uniq name kind arity tyvars ty + -> hsep [ ptext SLIT("type"), + ppr sty name, + hsep (map (pprTyVarBndr sty) tyvars), + ptext SLIT("="), + ppr sty ty, + semi + ] + other -> pprPanic "pprIfaceTyDecl" (ppr PprDebug tycon) + where + keyword NewType = SLIT("newtype") + keyword DataType = SLIT("data") + + ppr_con data_con + | null field_labels + = hsep [ ppr sty name, + hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) + ] + + | otherwise + = hsep [ ppr sty name, + braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) + ] + where + field_labels = dataConFieldLabels data_con + arg_tys = dataConRawArgTys data_con + strict_marks = dataConStrictMarks data_con + name = getName data_con + + ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType sty ty + + ppr_strict_mark NotMarkedStrict = empty + ppr_strict_mark MarkedStrict = ptext SLIT("! ") + -- The extra space helps the lexical analyser that lexes + -- interface files; it doesn't make the rigid operator/identifier + -- distinction, so "!a" is a valid identifier so far as it is concerned + + ppr_field (strict_mark, field_label) + = hsep [ ppr sty (fieldLabelName field_label), + ptext SLIT("::"), + ppr_strict_mark strict_mark <> pprParendType sty (fieldLabelType field_label) + ] + +ifaceClass sty clas + = hsep [ptext SLIT("class"), + ppr_decl_context sty theta, + ppr sty clas, -- Print the name + pprTyVarBndr sty tyvar, + pp_ops, + semi + ] + where + (tyvar, super_classes, ops) = classSig clas + theta = super_classes `zip` repeat (mkTyVarTy tyvar) + + pp_ops | null ops = empty + | otherwise = hsep [ptext SLIT("where"), + braces (hsep (punctuate semi (map ppr_classop ops))) + ] + + ppr_classop op = hsep [ppr sty (getOccName op), + ptext SLIT("::"), + ppr sty (classOpLocalType op) + ] + +ppr_decl_context :: PprStyle -> [(Class,Type)] -> Doc +ppr_decl_context sty [] = empty +ppr_decl_context sty theta + = braces (hsep (punctuate comma (map (ppr_dict) theta))) + <> + ptext SLIT(" =>") + where + ppr_dict (clas,ty) = hsep [ppr sty clas, ppr sty ty] +\end{code} + +%************************************************************************ +%* * +\subsection{Random small things} +%* * +%************************************************************************ + When printing export lists, we print like this: Avail f f AvailTC C [C, x, y] C(x,y) AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C \begin{code} -upp_avail NotAvailable = uppNil +upp_avail NotAvailable = empty upp_avail (Avail name) = upp_occname (getOccName name) -upp_avail (AvailTC name []) = uppNil -upp_avail (AvailTC name ns) = uppBesides [upp_occname (getOccName name), bang, upp_export ns'] +upp_avail (AvailTC name []) = empty +upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns'] where - bang | name `elem` ns = uppNil - | otherwise = uppChar '!' + bang | name `elem` ns = empty + | otherwise = char '!' ns' = filter (/= name) ns -upp_export [] = uppNil -upp_export names = uppBesides [uppChar '(', - uppIntersperse uppSP (map (upp_occname . getOccName) names), - uppChar ')'] +upp_export [] = empty +upp_export names = hcat [char '(', + hsep (map (upp_occname . getOccName) names), + char ')'] -upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP, - uppInt prec, uppSP, - upp_occname occ, uppSemi] -upp_dir InfixR = uppPStr SLIT("infixr") -upp_dir InfixL = uppPStr SLIT("infixl") -upp_dir InfixN = uppPStr SLIT("infix") +upp_fixity (occ, (Fixity prec dir, prov)) = hcat [upp_dir dir, space, + int prec, space, + upp_occname occ, semi] +upp_dir InfixR = ptext SLIT("infixr") +upp_dir InfixL = ptext SLIT("infixl") +upp_dir InfixN = ptext SLIT("infix") -ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name +ppr_unqual_name :: NamedThing a => a -> Doc -- Just its occurrence name ppr_unqual_name name = upp_occname (getOccName name) -ppr_name :: NamedThing a => a -> Unpretty -- Its full name -ppr_name n = uppPStr (nameString (getName n)) +ppr_name :: NamedThing a => a -> Doc -- Its full name +ppr_name n = ptext (nameString (getName n)) -upp_occname :: OccName -> Unpretty -upp_occname occ = uppPStr (occNameString occ) +upp_occname :: OccName -> Doc +upp_occname occ = ptext (occNameString occ) -upp_module :: Module -> Unpretty -upp_module mod = uppPStr mod +upp_module :: Module -> Doc +upp_module mod = ptext mod -uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util +uppSemid x = ppr PprInterface x <> semi -- micro util -ppr_ty ty = prettyToUn (pprType PprInterface ty) -ppr_tyvar tv = prettyToUn (ppr PprInterface tv) -ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv) +ppr_ty ty = pprType PprInterface ty +ppr_tyvar tv = ppr PprInterface tv +ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv -ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi +ppr_decl decl = ppr PprInterface decl <> semi renumber_ty ty = initNmbr (nmbrType ty) \end{code} @@ -463,9 +570,12 @@ lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 \begin{code} hPutCol :: Handle - -> (a -> Unpretty) + -> (a -> Doc) -> [a] -> IO () -hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >> - hPutStr hdl "\n" +hPutCol hdl fmt xs = mapIO (printDoc OneLineMode hdl . fmt) xs + +mapIO :: (a -> IO b) -> [a] -> IO () +mapIO f [] = return () +mapIO f (x:xs) = f x >> mapIO f xs \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 864b2f3..7dcc67f 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -14,12 +14,17 @@ import AbsCSyn import Stix import MachMisc +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import AbsCUtils ( getAmodeRep, mixedTypeLocn, nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList ) import Constants ( mIN_UPD_SIZE ) +import CLabel ( CLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, closureUpdReqd ) diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 3a87fec..fad3653 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -11,7 +11,11 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(IO(Handle)) import MachMisc +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import MachCode import PprMach @@ -23,8 +27,9 @@ import PrimOp ( commutableOp, PrimOp(..) ) import PrimRep ( PrimRep{-instance Eq-} ) import RegAllocInfo ( mkMRegsState, MRegsState ) import Stix ( StixTree(..), StixReg(..), CodeSegment ) -import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) ) -import Unpretty ( uppPutStr, uppShow, uppAboves, SYN_IE(Unpretty) ) +import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM), UniqSupply ) +import Outputable ( printDoc ) +import Pretty ( Doc, vcat, Mode(..) ) \end{code} The 96/03 native-code generator has machine-independent and @@ -59,7 +64,7 @@ The machine-dependent bits break down as follows: machine instructions. \item[@PprMach@:] @pprInstr@ turns an @Instr@ into text (well, really - an @Unpretty@). + an @Doc@). \item[@RegAllocInfo@:] In the register allocator, we manipulate @MRegsState@s, which are @BitSet@s, one bit per machine register. @@ -75,13 +80,11 @@ The machine-dependent bits break down as follows: So, here we go: \begin{code} writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO () - writeRealAsm handle absC us - = _scc_ "writeRealAsm" (uppPutStr handle 80 (runNCG absC us)) + = _scc_ "writeRealAsm" (printDoc LeftMode handle (runNCG absC us)) dumpRealAsm :: AbstractC -> UniqSupply -> String - -dumpRealAsm absC us = uppShow 80 (runNCG absC us) +dumpRealAsm absC us = show (runNCG absC us) runNCG absC = genCodeAbstractC absC `thenUs` \ treelists -> @@ -93,14 +96,14 @@ runNCG absC @codeGen@ is the top-level code-generation function: \begin{code} -codeGen :: [[StixTree]] -> UniqSM Unpretty +codeGen :: [[StixTree]] -> UniqSM Doc codeGen trees = mapUs genMachCode trees `thenUs` \ dynamic_codes -> let static_instrs = scheduleMachCode dynamic_codes in - returnUs (uppAboves (map pprInstr static_instrs)) + returnUs (vcat (map pprInstr static_instrs)) \end{code} Top level code generator for a chunk of stix code: diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index b7e85f8..54af675 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -12,7 +12,11 @@ IMP_Ubiq(){-uitous-} import MachCode ( SYN_IE(InstrList) ) import MachMisc ( Instr ) +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import RegAllocInfo import AbsCSyn ( MagicId ) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index de2bb90..5b5833a 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -17,23 +17,34 @@ module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where IMP_Ubiq(){-uitious-} import MachMisc -- may differ per-platform +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr(..)) +import qualified MachRegs (Addr(..)) +#define MachRegsAddr MachRegs.Addr +#define MachRegsAddrRegImm MachRegs.AddrRegImm +#define MachRegsAddrRegReg MachRegs.AddrRegReg +#else import MachRegs +#define MachRegsAddr Addr +#define MachRegsAddrRegImm AddrRegImm +#define MachRegsAddrRegReg AddrRegReg +#endif import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) -import CLabel ( isAsmTemp ) +import CLabel ( isAsmTemp, CLabel ) import Maybes ( maybeToBool, expectJust ) import OrdList -- quite a bit of it -import Pretty ( prettyToUn, ppRational ) +import PprStyle +import Pretty ( ptext, rational ) import PrimRep ( isFloatingRep, PrimRep(..) ) -import PrimOp ( PrimOp(..) ) +import PrimOp ( PrimOp(..), showPrimOp ) import Stix ( getUniqLabelNCG, StixTree(..), StixReg(..), CodeSegment(..) ) import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, mapAccumLUs, SYN_IE(UniqSM) ) -import Unpretty ( uppPStr ) import Util ( panic, assertPanic ) \end{code} @@ -274,7 +285,7 @@ getRegister (StDouble d) let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, - DATA TF [ImmLab (prettyToUn (ppRational d))], + DATA TF [ImmLab (rational d)], SEGMENT TextSegment, LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] @@ -674,7 +685,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -731,7 +742,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code2 = registerCode register2 tmp2 asmVoid src2 = registerName register2 tmp2 code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -746,7 +757,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst)) in returnUs (Any IntRep code__2) @@ -789,10 +800,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps src2 = ImmInt (fromInteger i) code__2 = asmParThen [code1] . mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) @@ -812,10 +823,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps CLTD, IDIV sz (OpReg src2)] else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), + MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), MOV L (OpReg src1) (OpReg eax), CLTD, - IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] + IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))] in returnUs (Fixed IntRep (if is_division then eax else edx) code__2) ----------------------- @@ -864,7 +875,7 @@ getRegister (StDouble d) DATA DF [dblImmLit d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, - LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst] in returnUs (Any DoubleRep code) @@ -872,10 +883,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (SUB False False g0) x IntAbsOp -> absIntCode x - NotOp -> trivialUCode (XNOR False g0) x FloatNegOp -> trivialUFCode FloatRep (FNEG F) x + DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x @@ -901,6 +912,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps = case primop of FloatExpOp -> (True, SLIT("exp")) FloatLogOp -> (True, SLIT("log")) + FloatSqrtOp -> (True, SLIT("sqrt")) FloatSinOp -> (True, SLIT("sin")) FloatCosOp -> (True, SLIT("cos")) @@ -916,6 +928,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) + DoubleSqrtOp -> (True, SLIT("sqrt")) DoubleSinOp -> (False, SLIT("sin")) DoubleCosOp -> (False, SLIT("cos")) @@ -928,6 +941,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) + _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -1048,7 +1062,7 @@ getRegister leaf @Amode@s: Memory addressing modes passed up the tree. \begin{code} -data Amode = Amode Addr InstrBlock +data Amode = Amode MachRegsAddr InstrBlock amodeAddr (Amode addr _) = addr amodeCode (Amode _ code) = code @@ -1072,7 +1086,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnUs (Amode (MachRegsAddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) = getNewRegNCG PtrRep `thenUs` \ tmp -> @@ -1082,7 +1096,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnUs (Amode (MachRegsAddrRegImm reg off) code) getAmode leaf | maybeToBool imm @@ -1112,7 +1126,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (Addr (Just reg) Nothing off) code) + returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm @@ -1132,7 +1146,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (Addr (Just reg) Nothing off) code) + returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenUs` \ tmp1 -> @@ -1146,7 +1160,7 @@ getAmode (StPrim IntAddOp [x, y]) reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] in - returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) getAmode leaf | maybeToBool imm @@ -1166,7 +1180,7 @@ getAmode other reg = registerName register tmp off = Nothing in - returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code) + returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1181,7 +1195,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnUs (Amode (MachRegsAddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) @@ -1193,7 +1207,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnUs (Amode (MachRegsAddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenUs` \ tmp1 -> @@ -1207,7 +1221,7 @@ getAmode (StPrim IntAddOp [x, y]) reg2 = registerName register2 tmp2 code__2 = asmParThen [code1, code2] in - returnUs (Amode (AddrRegReg reg1 reg2) code__2) + returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm @@ -1215,7 +1229,7 @@ getAmode leaf let code = mkSeqInstr (SETHI (HI imm__2) tmp) in - returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) + returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x @@ -1228,7 +1242,7 @@ getAmode other reg = registerName register tmp off = ImmInt 0 in - returnUs (Amode (AddrRegImm reg off) code) + returnUs (Amode (MachRegsAddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -1923,7 +1937,7 @@ genJump tree code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (AddrRegReg target g0), NOP] + returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP] #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2164,7 +2178,7 @@ genCCall fn kind args code = asmParThen (map ($ asmVoid) argCode) in returnSeq code [ - LDA pv (AddrImm (ImmLab (uppPStr fn))), + LDA pv (AddrImm (ImmLab (ptext fn))), JSR ra (AddrReg pv) nRegs, LDGP gp (AddrReg ra)] where @@ -2231,8 +2245,8 @@ genCCall fn kind [StInt i] call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), MOV L (OpImm (ImmCLbl lbl)) -- this is hardwired - (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))), - JMP (OpImm (ImmLit (uppPStr (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))), + (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))), + JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))), LABEL lbl] in returnInstrs call @@ -2241,14 +2255,14 @@ genCCall fn kind args = mapUs get_call_arg args `thenUs` \ argCode -> let nargs = length args - code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))), - MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp) + code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))), + MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp) ] ] code2 = asmParThen (map ($ asmVoid) (reverse argCode)) call = [CALL fn__2 -- , -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp), - -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp) + -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp) ] in returnSeq (code1 . code2) call @@ -2258,8 +2272,8 @@ genCCall fn kind args -- underscore prefix -- ToDo:needed (WDP 96/03) ??? fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (uppPStr fn) - _ -> ImmLab (uppPStr fn) + '.' -> ImmLit (ptext fn) + _ -> ImmLab (ptext fn) ------------ get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code @@ -2316,8 +2330,8 @@ genCCall fn kind args -- underscore prefix -- ToDo:needed (WDP 96/03) ??? fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (uppPStr fn) - _ -> ImmLab (uppPStr fn) + '.' -> ImmLit (ptext fn) + _ -> ImmLab (ptext fn) ------------------------------------ {- Try to get a value into a specific register (or registers) for @@ -3045,8 +3059,8 @@ coerceInt2FP pk x code__2 dst = code . mkSeqInstrs [ -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))), + FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] in returnUs (Any pk code__2) @@ -3062,8 +3076,8 @@ coerceFP2Int x code__2 dst = let in code . mkSeqInstrs [ FRNDINT, - FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)), + MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] in returnUs (Any IntRep code__2) diff --git a/ghc/compiler/nativeGen/MachMisc.hi-boot b/ghc/compiler/nativeGen/MachMisc.hi-boot new file mode 100644 index 0000000..e12bce6 --- /dev/null +++ b/ghc/compiler/nativeGen/MachMisc.hi-boot @@ -0,0 +1,8 @@ +_interface_ MachMisc 1 +_exports_ +MachMisc fixedHdrSizeInWords fmtAsmLbl varHdrSizeInWords underscorePrefix; +_declarations_ +1 fixedHdrSizeInWords _:_ PrelBase.Int ;; +2 fmtAsmLbl _:_ PrelBase.String -> PrelBase.String ;; +1 varHdrSizeInWords _:_ SMRep.SMRep -> PrelBase.Int ;; +1 underscorePrefix _:_ PrelBase.Bool ;; diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index a3eb463..58ce3b4 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -48,11 +48,21 @@ IMPORT_1_3(Char(isDigit)) import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) +import CLabel ( CLabel ) import CmdLineOpts ( opt_SccProfilingOn ) import Literal ( mkMachInt, Literal(..) ) import MachRegs ( stgReg, callerSaves, RegLoc(..), - Imm(..), Reg(..), Addr + Imm(..), Reg(..) +#if __GLASGOW_HASKELL__ >= 202 + ) +import qualified MachRegs (Addr) +#define MachRegsAddr MachRegs.Addr +#else + , Addr(..) ) +#define MachRegsAddr Addr +#endif + import OrdList ( OrdList ) import PrimRep ( PrimRep(..) ) import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) @@ -436,12 +446,12 @@ data Instr -- Loads and stores. - | LD Size Reg Addr -- size, dst, src - | LDA Reg Addr -- dst, src - | LDAH Reg Addr -- dst, src - | LDGP Reg Addr -- dst, src + | LD Size Reg MachRegsAddr -- size, dst, src + | LDA Reg MachRegsAddr -- dst, src + | LDAH Reg MachRegsAddr -- dst, src + | LDGP Reg MachRegsAddr -- dst, src | LDI Size Reg Imm -- size, dst, src - | ST Size Reg Addr -- size, src, dst + | ST Size Reg MachRegsAddr -- size, src, dst -- Int Arithmetic. @@ -496,9 +506,9 @@ data Instr | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm - | JMP Reg Addr Int + | JMP Reg MachRegsAddr Int | BSR Imm Int - | JSR Reg Addr Int + | JSR Reg MachRegsAddr Int -- Alpha-specific pseudo-ops. @@ -559,25 +569,25 @@ data RI | FABS | FADD Size Operand -- src | FADDP - | FIADD Size Addr -- src + | FIADD Size MachRegsAddr -- src | FCHS | FCOM Size Operand -- src | FCOS | FDIV Size Operand -- src | FDIVP - | FIDIV Size Addr -- src + | FIDIV Size MachRegsAddr -- src | FDIVR Size Operand -- src | FDIVRP - | FIDIVR Size Addr -- src - | FICOM Size Addr -- src - | FILD Size Addr Reg -- src, dst - | FIST Size Addr -- dst + | FIDIVR Size MachRegsAddr -- src + | FICOM Size MachRegsAddr -- src + | FILD Size MachRegsAddr Reg -- src, dst + | FIST Size MachRegsAddr -- dst | FLD Size Operand -- src | FLD1 | FLDZ | FMUL Size Operand -- src | FMULP - | FIMUL Size Addr -- src + | FIMUL Size MachRegsAddr -- src | FRNDINT | FSIN | FSQRT @@ -585,10 +595,10 @@ data RI | FSTP Size Operand -- dst | FSUB Size Operand -- src | FSUBP - | FISUB Size Addr -- src + | FISUB Size MachRegsAddr -- src | FSUBR Size Operand -- src | FSUBRP - | FISUBR Size Addr -- src + | FISUBR Size MachRegsAddr -- src | FTST | FCOMP Size Operand -- src | FUCOMPP @@ -618,9 +628,9 @@ data RI | CLTD -- sign extend %eax into %edx:%eax data Operand - = OpReg Reg -- register - | OpImm Imm -- immediate value - | OpAddr Addr -- memory reference + = OpReg Reg -- register + | OpImm Imm -- immediate value + | OpAddr MachRegsAddr -- memory reference #endif {- i386_TARGET_ARCH -} \end{code} @@ -632,8 +642,8 @@ data Operand -- Loads and stores. - | LD Size Addr Reg -- size, src, dst - | ST Size Reg Addr -- size, src, dst + | LD Size MachRegsAddr Reg -- size, src, dst + | ST Size Reg MachRegsAddr -- size, src, dst -- Int Arithmetic. @@ -675,7 +685,7 @@ data Operand | BI Cond Bool Imm -- cond, annul?, target | BF Cond Bool Imm -- cond, annul?, target - | JMP Addr -- target + | JMP MachRegsAddr -- target | CALL Imm Int Bool -- target, args, terminal data RI = RIReg Reg diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 19ad571..2baaf71 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -59,11 +59,19 @@ module MachRegs ( #endif ) where +#if __GLASGOW_HASKELL__ >= 202 +import GlaExts hiding (Addr) +import FastString +import Ubiq +#else IMP_Ubiq(){-uitous-} +#endif import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) -import Pretty ( ppStr, ppRational, ppShow ) +import CLabel ( CLabel ) +import Outputable ( Outputable(..) ) +import Pretty ( Doc, text, rational ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix ( sStLitLbl, StixTree(..), StixReg(..), @@ -73,8 +81,7 @@ import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, Unique{-instance Ord3-} ) import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) ) -import Unpretty ( uppStr, SYN_IE(Unpretty) ) -import Util ( panic ) +import Util ( panic, Ord3(..) ) \end{code} % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -84,20 +91,20 @@ data Imm = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLab Unpretty -- Simple string label (underscore-able) - | ImmLit Unpretty -- Simple string + | ImmLab Doc -- Simple string label (underscore-able) + | ImmLit Doc -- Simple string IF_ARCH_sparc( | LO Imm -- Possible restrictions... | HI Imm ,) -strImmLit s = ImmLit (uppStr s) +strImmLit s = ImmLit (text s) dblImmLit r = strImmLit ( IF_ARCH_alpha({-prepend nothing-} ,IF_ARCH_i386( '0' : 'd' : ,IF_ARCH_sparc('0' : 'r' :,))) - ppShow 80 (ppRational r)) + show (rational r)) \end{code} % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -307,7 +314,7 @@ instance Text Reg where #ifdef DEBUG instance Outputable Reg where - ppr sty r = ppStr (show r) + ppr sty r = text (show r) #endif cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i' diff --git a/ghc/compiler/nativeGen/NcgLoop.hs b/ghc/compiler/nativeGen/NcgLoop.hs new file mode 100644 index 0000000..009107b --- /dev/null +++ b/ghc/compiler/nativeGen/NcgLoop.hs @@ -0,0 +1,12 @@ +module NcgLoop + + ( + module StixPrim, + module MachMisc, + module Stix + ) where + +import StixPrim +import MachMisc +import Stix + diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 9b2cd26..80c0c02 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -13,9 +13,18 @@ We start with the @pprXXX@s with some cross-platform commonality module PprMach ( pprInstr ) where -IMP_Ubiq(){-uitious-} IMPORT_1_3(Char(isPrint,isDigit)) -IMPORT_1_3(qualified GHCbase(Addr(..))) -- to see innards +#if __GLASGOW_HASKELL__ == 201 +import qualified GHCbase(Addr(..)) -- to see innards +IMP_Ubiq(){-uitious-} +#elif __GLASGOW_HASKELL__ >= 202 +import qualified GlaExts (Addr(..)) +import GlaExts hiding (Addr(..)) +import FastString +import Ubiq +#else +IMP_Ubiq(){-uitious-} +#endif import MachRegs -- may differ per-platform import MachMisc @@ -26,11 +35,14 @@ import CStrings ( charToC ) import Maybes ( maybeToBool ) import OrdList ( OrdList ) import Stix ( CodeSegment(..), StixTree ) -import Unpretty -- all of it +import Pretty -- all of it -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 a_HASH x = GHCbase.A# x pACK_STR x = packCString x +#elif __GLASGOW_HASKELL__ >= 202 +a_HASH x = GlaExts.A# x +pACK_STR x = mkFastCharString x #else a_HASH x = A# x pACK_STR x = mkFastCharString x --_packCString x @@ -46,17 +58,17 @@ pACK_STR x = mkFastCharString x --_packCString x For x86, the way we print a register name depends on which bit of it we care about. Yurgh. \begin{code} -pprReg :: IF_ARCH_i386(Size ->,) Reg -> Unpretty +pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc pprReg IF_ARCH_i386(s,) r = case r of FixedReg i -> ppr_reg_no IF_ARCH_i386(s,) i MappedReg i -> ppr_reg_no IF_ARCH_i386(s,) i - other -> uppStr (show other) -- should only happen when debugging + other -> text (show other) -- should only happen when debugging where #if alpha_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Unpretty - ppr_reg_no i = uppPStr + ppr_reg_no :: FAST_REG_NO -> Doc + ppr_reg_no i = ptext (case i of { ILIT( 0) -> SLIT("$0"); ILIT( 1) -> SLIT("$1"); ILIT( 2) -> SLIT("$2"); ILIT( 3) -> SLIT("$3"); @@ -94,8 +106,8 @@ pprReg IF_ARCH_i386(s,) r }) #endif #if i386_TARGET_ARCH - ppr_reg_no :: Size -> FAST_REG_NO -> Unpretty - ppr_reg_no B i = uppPStr + ppr_reg_no :: Size -> FAST_REG_NO -> Doc + ppr_reg_no B i = ptext (case i of { ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl"); ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl"); @@ -103,7 +115,7 @@ pprReg IF_ARCH_i386(s,) r }) {- UNUSED: - ppr_reg_no HB i = uppPStr + ppr_reg_no HB i = ptext (case i of { ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh"); ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh"); @@ -112,7 +124,7 @@ pprReg IF_ARCH_i386(s,) r -} {- UNUSED: - ppr_reg_no S i = uppPStr + ppr_reg_no S i = ptext (case i of { ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx"); ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx"); @@ -122,7 +134,7 @@ pprReg IF_ARCH_i386(s,) r }) -} - ppr_reg_no L i = uppPStr + ppr_reg_no L i = ptext (case i of { ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx"); ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx"); @@ -131,7 +143,7 @@ pprReg IF_ARCH_i386(s,) r _ -> SLIT("very naughty I386 double word register") }) - ppr_reg_no F i = uppPStr + ppr_reg_no F i = ptext (case i of { --ToDo: rm these (???) ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); @@ -141,7 +153,7 @@ pprReg IF_ARCH_i386(s,) r _ -> SLIT("very naughty I386 float register") }) - ppr_reg_no DF i = uppPStr + ppr_reg_no DF i = ptext (case i of { --ToDo: rm these (???) ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)"); @@ -152,8 +164,8 @@ pprReg IF_ARCH_i386(s,) r }) #endif #if sparc_TARGET_ARCH - ppr_reg_no :: FAST_REG_NO -> Unpretty - ppr_reg_no i = uppPStr + ppr_reg_no :: FAST_REG_NO -> Doc + ppr_reg_no i = ptext (case i of { ILIT( 0) -> SLIT("%g0"); ILIT( 1) -> SLIT("%g1"); ILIT( 2) -> SLIT("%g2"); ILIT( 3) -> SLIT("%g3"); @@ -199,9 +211,9 @@ pprReg IF_ARCH_i386(s,) r %************************************************************************ \begin{code} -pprSize :: Size -> Unpretty +pprSize :: Size -> Doc -pprSize x = uppPStr (case x of +pprSize x = ptext (case x of #if alpha_TARGET_ARCH B -> SLIT("b") BU -> SLIT("bu") @@ -232,6 +244,17 @@ pprSize x = uppPStr (case x of F -> SLIT("") -- D -> SLIT("d") UNUSED DF -> SLIT("d") + ) +pprStSize :: Size -> Doc +pprStSize x = ptext (case x of + B -> SLIT("b") + BU -> SLIT("b") +-- HW -> SLIT("hw") UNUSED +-- HWU -> SLIT("uhw") UNUSED + W -> SLIT("") + F -> SLIT("") +-- D -> SLIT("d") UNUSED + DF -> SLIT("d") #endif ) \end{code} @@ -243,9 +266,9 @@ pprSize x = uppPStr (case x of %************************************************************************ \begin{code} -pprCond :: Cond -> Unpretty +pprCond :: Cond -> Doc -pprCond c = uppPStr (case c of { +pprCond c = ptext (case c of { #if alpha_TARGET_ARCH EQQ -> SLIT("eq"); LTT -> SLIT("lt"); @@ -285,26 +308,26 @@ pprCond c = uppPStr (case c of { %************************************************************************ \begin{code} -pprImm :: Imm -> Unpretty +pprImm :: Imm -> Doc -pprImm (ImmInt i) = uppInt i -pprImm (ImmInteger i) = uppInteger i +pprImm (ImmInt i) = int i +pprImm (ImmInteger i) = integer i pprImm (ImmCLbl l) = pprCLabel_asm l pprImm (ImmLit s) = s -pprImm (ImmLab s) | underscorePrefix = uppBeside (uppChar '_') s +pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s | otherwise = s #if sparc_TARGET_ARCH pprImm (LO i) - = uppBesides [ pp_lo, pprImm i, uppRparen ] + = hcat [ pp_lo, pprImm i, rparen ] where - pp_lo = uppPStr (pACK_STR (a_HASH "%lo("#)) + pp_lo = ptext (pACK_STR (a_HASH "%lo("#)) pprImm (HI i) - = uppBesides [ pp_hi, pprImm i, uppRparen ] + = hcat [ pp_hi, pprImm i, rparen ] where - pp_hi = uppPStr (pACK_STR (a_HASH "%hi("#)) + pp_hi = ptext (pACK_STR (a_HASH "%hi("#)) #endif \end{code} @@ -315,13 +338,13 @@ pprImm (HI i) %************************************************************************ \begin{code} -pprAddr :: Addr -> Unpretty +pprAddr :: Addr -> Doc #if alpha_TARGET_ARCH -pprAddr (AddrReg r) = uppParens (pprReg r) +pprAddr (AddrReg r) = parens (pprReg r) pprAddr (AddrImm i) = pprImm i pprAddr (AddrRegImm r1 i) - = uppBeside (pprImm i) (uppParens (pprReg r1)) + = (<>) (pprImm i) (parens (pprReg r1)) #endif ------------------- @@ -334,23 +357,23 @@ pprAddr (ImmAddr imm off) if (off == 0) then pp_imm else if (off < 0) then - uppBeside pp_imm (uppInt off) + (<>) pp_imm (int off) else - uppBesides [pp_imm, uppChar '+', uppInt off] + hcat [pp_imm, char '+', int off] pprAddr (Addr base index displacement) = let pp_disp = ppr_disp displacement - pp_off p = uppBeside pp_disp (uppParens p) + pp_off p = (<>) pp_disp (parens p) pp_reg r = pprReg L r in case (base,index) of (Nothing, Nothing) -> pp_disp (Just b, Nothing) -> pp_off (pp_reg b) - (Nothing, Just (r,i)) -> pp_off (uppBesides [pp_reg r, uppComma, uppInt i]) - (Just b, Just (r,i)) -> pp_off (uppBesides [pp_reg b, uppComma, pp_reg r, uppComma, uppInt i]) + (Nothing, Just (r,i)) -> pp_off (hcat [pp_reg r, comma, int i]) + (Just b, Just (r,i)) -> pp_off (hcat [pp_reg b, comma, pp_reg r, comma, int i]) where - ppr_disp (ImmInt 0) = uppNil + ppr_disp (ImmInt 0) = empty ppr_disp imm = pprImm imm #endif @@ -360,24 +383,24 @@ pprAddr (Addr base index displacement) pprAddr (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1 pprAddr (AddrRegReg r1 r2) - = uppBesides [ pprReg r1, uppChar '+', pprReg r2 ] + = hcat [ pprReg r1, char '+', pprReg r2 ] pprAddr (AddrRegImm r1 (ImmInt i)) | i == 0 = pprReg r1 | not (fits13Bits i) = largeOffsetError i - | otherwise = uppBesides [ pprReg r1, pp_sign, uppInt i ] + | otherwise = hcat [ pprReg r1, pp_sign, int i ] where - pp_sign = if i > 0 then uppChar '+' else uppNil + pp_sign = if i > 0 then char '+' else empty pprAddr (AddrRegImm r1 (ImmInteger i)) | i == 0 = pprReg r1 | not (fits13Bits i) = largeOffsetError i - | otherwise = uppBesides [ pprReg r1, pp_sign, uppInteger i ] + | otherwise = hcat [ pprReg r1, pp_sign, integer i ] where - pp_sign = if i > 0 then uppChar '+' else uppNil + pp_sign = if i > 0 then char '+' else empty pprAddr (AddrRegImm r1 imm) - = uppBesides [ pprReg r1, uppChar '+', pprImm imm ] + = hcat [ pprReg r1, char '+', pprImm imm ] #endif \end{code} @@ -388,22 +411,22 @@ pprAddr (AddrRegImm r1 imm) %************************************************************************ \begin{code} -pprInstr :: Instr -> Unpretty +pprInstr :: Instr -> Doc -pprInstr (COMMENT s) = uppNil -- nuke 'em ---alpha: = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s) ---i386 : = uppBeside (uppPStr SLIT("# ")) (uppPStr s) ---sparc: = uppBeside (uppPStr SLIT("! ")) (uppPStr s) +pprInstr (COMMENT s) = empty -- nuke 'em +--alpha: = (<>) (ptext SLIT("\t# ")) (ptext s) +--i386 : = (<>) (ptext SLIT("# ")) (ptext s) +--sparc: = (<>) (ptext SLIT("! ")) (ptext s) pprInstr (SEGMENT TextSegment) - = uppPStr + = ptext IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-} ,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-} ,IF_ARCH_i386((_PK_ ".text\n\t.align 2\x2c\&0x90") {-needs per-OS variation!-} ,))) pprInstr (SEGMENT DataSegment) - = uppPStr + = ptext IF_ARCH_alpha(SLIT("\t.data\n\t.align 3") ,IF_ARCH_sparc(SLIT("\t.data\n\t.align 8") {-<8 will break double constants -} ,IF_ARCH_i386(SLIT(".data\n\t.align 2") @@ -413,41 +436,40 @@ pprInstr (LABEL clab) = let pp_lab = pprCLabel_asm clab in - uppBesides [ + hcat [ if not (externallyVisibleCLabel clab) then - uppNil + empty else - uppBesides [uppPStr + hcat [ptext IF_ARCH_alpha(SLIT("\t.globl\t") ,IF_ARCH_i386(SLIT(".globl ") ,IF_ARCH_sparc(SLIT("\t.global\t") ,))) - , pp_lab, uppChar '\n'], + , pp_lab, char '\n'], pp_lab, - uppChar ':' + char ':' ] pprInstr (ASCII False{-no backslash conversion-} str) - = uppBesides [ uppPStr SLIT("\t.asciz "), uppChar '\"', uppStr str, uppChar '"' ] + = hcat [ ptext SLIT("\t.asciz "), char '\"', text str, char '"' ] pprInstr (ASCII True str) - = uppBeside (uppStr "\t.ascii \"") (asciify str 60) + = (<>) (text "\t.ascii \"") (asciify str 60) where - asciify :: String -> Int -> Unpretty - - asciify [] _ = uppStr "\\0\"" - asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60) - asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1)) - asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1)) - asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1)) - asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\"")) + asciify :: String -> Int -> Doc + + asciify [] _ = text "\\0\"" + asciify s n | n <= 0 = (<>) (text "\"\n\t.ascii \"") (asciify s 60) + asciify ('\\':cs) n = (<>) (text "\\\\") (asciify cs (n-1)) + asciify ('\"':cs) n = (<>) (text "\\\"") (asciify cs (n-1)) + asciify (c:cs) n | isPrint c = (<>) (char c) (asciify cs (n-1)) + asciify [c] _ = (<>) (text (charToC c)) (text ("\\0\"")) asciify (c:(cs@(d:_))) n - | isDigit d = uppBeside (uppStr (charToC c)) (asciify cs 0) - | otherwise = uppBeside (uppStr (charToC c)) (asciify cs (n-1)) + | isDigit d = (<>) (text (charToC c)) (asciify cs 0) + | otherwise = (<>) (text (charToC c)) (asciify cs (n-1)) pprInstr (DATA s xs) - = uppInterleave (uppChar '\n') - [uppBeside (uppPStr pp_size) (pprImm x) | x <- xs] + = vcat [(<>) (ptext pp_size) (pprImm x) | x <- xs] where pp_size = case s of #if alpha_TARGET_ARCH @@ -491,177 +513,177 @@ pprInstr (DATA s xs) #if alpha_TARGET_ARCH pprInstr (LD size reg addr) - = uppBesides [ - uppPStr SLIT("\tld"), + = hcat [ + ptext SLIT("\tld"), pprSize size, - uppChar '\t', + char '\t', pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (LDA reg addr) - = uppBesides [ - uppPStr SLIT("\tlda\t"), + = hcat [ + ptext SLIT("\tlda\t"), pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (LDAH reg addr) - = uppBesides [ - uppPStr SLIT("\tldah\t"), + = hcat [ + ptext SLIT("\tldah\t"), pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (LDGP reg addr) - = uppBesides [ - uppPStr SLIT("\tldgp\t"), + = hcat [ + ptext SLIT("\tldgp\t"), pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (LDI size reg imm) - = uppBesides [ - uppPStr SLIT("\tldi"), + = hcat [ + ptext SLIT("\tldi"), pprSize size, - uppChar '\t', + char '\t', pprReg reg, - uppComma, + comma, pprImm imm ] pprInstr (ST size reg addr) - = uppBesides [ - uppPStr SLIT("\tst"), + = hcat [ + ptext SLIT("\tst"), pprSize size, - uppChar '\t', + char '\t', pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (CLR reg) - = uppBesides [ - uppPStr SLIT("\tclr\t"), + = hcat [ + ptext SLIT("\tclr\t"), pprReg reg ] pprInstr (ABS size ri reg) - = uppBesides [ - uppPStr SLIT("\tabs"), + = hcat [ + ptext SLIT("\tabs"), pprSize size, - uppChar '\t', + char '\t', pprRI ri, - uppComma, + comma, pprReg reg ] pprInstr (NEG size ov ri reg) - = uppBesides [ - uppPStr SLIT("\tneg"), + = hcat [ + ptext SLIT("\tneg"), pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', + if ov then ptext SLIT("v\t") else char '\t', pprRI ri, - uppComma, + comma, pprReg reg ] pprInstr (ADD size ov reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\tadd"), + = hcat [ + ptext SLIT("\tadd"), pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', + if ov then ptext SLIT("v\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (SADD size scale reg1 ri reg2) - = uppBesides [ - uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), - uppPStr SLIT("add"), + = hcat [ + ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), + ptext SLIT("add"), pprSize size, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (SUB size ov reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\tsub"), + = hcat [ + ptext SLIT("\tsub"), pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', + if ov then ptext SLIT("v\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (SSUB size scale reg1 ri reg2) - = uppBesides [ - uppPStr (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), - uppPStr SLIT("sub"), + = hcat [ + ptext (case scale of {{-UNUSED:L -> SLIT("\ts4");-} Q -> SLIT("\ts8")}), + ptext SLIT("sub"), pprSize size, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (MUL size ov reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\tmul"), + = hcat [ + ptext SLIT("\tmul"), pprSize size, - if ov then uppPStr SLIT("v\t") else uppChar '\t', + if ov then ptext SLIT("v\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (DIV size uns reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\tdiv"), + = hcat [ + ptext SLIT("\tdiv"), pprSize size, - if uns then uppPStr SLIT("u\t") else uppChar '\t', + if uns then ptext SLIT("u\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (REM size uns reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\trem"), + = hcat [ + ptext SLIT("\trem"), pprSize size, - if uns then uppPStr SLIT("u\t") else uppChar '\t', + if uns then ptext SLIT("u\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (NOT ri reg) - = uppBesides [ - uppPStr SLIT("\tnot"), - uppChar '\t', + = hcat [ + ptext SLIT("\tnot"), + char '\t', pprRI ri, - uppComma, + comma, pprReg reg ] @@ -679,41 +701,41 @@ pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") reg1 ri reg2 pprInstr (ZAP reg1 ri reg2) = pprRegRIReg SLIT("zap") reg1 ri reg2 pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg SLIT("zapnot") reg1 ri reg2 -pprInstr (NOP) = uppPStr SLIT("\tnop") +pprInstr (NOP) = ptext SLIT("\tnop") pprInstr (CMP cond reg1 ri reg2) - = uppBesides [ - uppPStr SLIT("\tcmp"), + = hcat [ + ptext SLIT("\tcmp"), pprCond cond, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] pprInstr (FCLR reg) - = uppBesides [ - uppPStr SLIT("\tfclr\t"), + = hcat [ + ptext SLIT("\tfclr\t"), pprReg reg ] pprInstr (FABS reg1 reg2) - = uppBesides [ - uppPStr SLIT("\tfabs\t"), + = hcat [ + ptext SLIT("\tfabs\t"), pprReg reg1, - uppComma, + comma, pprReg reg2 ] pprInstr (FNEG size reg1 reg2) - = uppBesides [ - uppPStr SLIT("\tneg"), + = hcat [ + ptext SLIT("\tneg"), pprSize size, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprReg reg2 ] @@ -723,94 +745,94 @@ pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("mul") size reg1 reg pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("sub") size reg1 reg2 reg3 pprInstr (CVTxy size1 size2 reg1 reg2) - = uppBesides [ - uppPStr SLIT("\tcvt"), + = hcat [ + ptext SLIT("\tcvt"), pprSize size1, - case size2 of {Q -> uppPStr SLIT("qc"); _ -> pprSize size2}, - uppChar '\t', + case size2 of {Q -> ptext SLIT("qc"); _ -> pprSize size2}, + char '\t', pprReg reg1, - uppComma, + comma, pprReg reg2 ] pprInstr (FCMP size cond reg1 reg2 reg3) - = uppBesides [ - uppPStr SLIT("\tcmp"), + = hcat [ + ptext SLIT("\tcmp"), pprSize size, pprCond cond, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprReg reg2, - uppComma, + comma, pprReg reg3 ] pprInstr (FMOV reg1 reg2) - = uppBesides [ - uppPStr SLIT("\tfmov\t"), + = hcat [ + ptext SLIT("\tfmov\t"), pprReg reg1, - uppComma, + comma, pprReg reg2 ] pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab) -pprInstr (BI NEVER reg lab) = uppNil +pprInstr (BI NEVER reg lab) = empty pprInstr (BI cond reg lab) - = uppBesides [ - uppPStr SLIT("\tb"), + = hcat [ + ptext SLIT("\tb"), pprCond cond, - uppChar '\t', + char '\t', pprReg reg, - uppComma, + comma, pprImm lab ] pprInstr (BF cond reg lab) - = uppBesides [ - uppPStr SLIT("\tfb"), + = hcat [ + ptext SLIT("\tfb"), pprCond cond, - uppChar '\t', + char '\t', pprReg reg, - uppComma, + comma, pprImm lab ] pprInstr (BR lab) - = uppBeside (uppPStr SLIT("\tbr\t")) (pprImm lab) + = (<>) (ptext SLIT("\tbr\t")) (pprImm lab) pprInstr (JMP reg addr hint) - = uppBesides [ - uppPStr SLIT("\tjmp\t"), + = hcat [ + ptext SLIT("\tjmp\t"), pprReg reg, - uppComma, + comma, pprAddr addr, - uppComma, - uppInt hint + comma, + int hint ] pprInstr (BSR imm n) - = uppBeside (uppPStr SLIT("\tbsr\t")) (pprImm imm) + = (<>) (ptext SLIT("\tbsr\t")) (pprImm imm) pprInstr (JSR reg addr n) - = uppBesides [ - uppPStr SLIT("\tjsr\t"), + = hcat [ + ptext SLIT("\tjsr\t"), pprReg reg, - uppComma, + comma, pprAddr addr ] pprInstr (FUNBEGIN clab) - = uppBesides [ + = hcat [ if (externallyVisibleCLabel clab) then - uppBesides [uppPStr SLIT("\t.globl\t"), pp_lab, uppChar '\n'] + hcat [ptext SLIT("\t.globl\t"), pp_lab, char '\n'] else - uppNil, - uppPStr SLIT("\t.ent "), + empty, + ptext SLIT("\t.ent "), pp_lab, - uppChar '\n', + char '\n', pp_lab, pp_ldgp, pp_lab, @@ -819,46 +841,46 @@ pprInstr (FUNBEGIN clab) where pp_lab = pprCLabel_asm clab - pp_ldgp = uppPStr (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#)) - pp_frame = uppPStr (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#)) + pp_ldgp = ptext (pACK_STR (a_HASH ":\n\tldgp $29,0($27)\n"#)) + pp_frame = ptext (pACK_STR (a_HASH "..ng:\n\t.frame $30,4240,$26,0\n\t.prologue 1"#)) pprInstr (FUNEND clab) - = uppBeside (uppPStr SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab) + = (<>) (ptext SLIT("\t.align 4\n\t.end ")) (pprCLabel_asm clab) \end{code} Continue with Alpha-only printing bits and bobs: \begin{code} -pprRI :: RI -> Unpretty +pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Unpretty +pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc pprRegRIReg name reg1 ri reg2 - = uppBesides [ - uppChar '\t', - uppPStr name, - uppChar '\t', + = hcat [ + char '\t', + ptext name, + char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppChar '\t', + char '\t', pprReg reg1, - uppComma, + comma, pprReg reg2, - uppComma, + comma, pprReg reg3 ] @@ -876,7 +898,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3 pprInstr (MOV size (OpReg src) (OpReg dst)) -- hack | src == dst - = uppPStr SLIT("") + = ptext SLIT("") pprInstr (MOV size src dst) = pprSizeOpOp SLIT("mov") size src dst pprInstr (MOVZX size src dst) = pprSizeOpOpCoerce SLIT("movzx") L size src dst @@ -919,171 +941,171 @@ pprInstr (TEST size src dst) = pprSizeOpOp SLIT("test") size src dst pprInstr (PUSH size op) = pprSizeOp SLIT("push") size op pprInstr (POP size op) = pprSizeOp SLIT("pop") size op -pprInstr (NOP) = uppPStr SLIT("\tnop") -pprInstr (CLTD) = uppPStr SLIT("\tcltd") +pprInstr (NOP) = ptext SLIT("\tnop") +pprInstr (CLTD) = ptext SLIT("\tcltd") pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op) pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab) -pprInstr (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm imm) -pprInstr (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand L op) +pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm) +pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op) pprInstr (CALL imm) - = uppBesides [ uppPStr SLIT("\tcall "), pprImm imm ] + = hcat [ ptext SLIT("\tcall "), pprImm imm ] -pprInstr SAHF = uppPStr SLIT("\tsahf") -pprInstr FABS = uppPStr SLIT("\tfabs") +pprInstr SAHF = ptext SLIT("\tsahf") +pprInstr FABS = ptext SLIT("\tfabs") pprInstr (FADD sz src@(OpAddr _)) - = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppSP, pprOperand sz src] + = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src] pprInstr (FADD sz src) - = uppPStr SLIT("\tfadd") + = ptext SLIT("\tfadd") pprInstr FADDP - = uppPStr SLIT("\tfaddp") + = ptext SLIT("\tfaddp") pprInstr (FMUL sz src) - = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppSP, pprOperand sz src] + = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src] pprInstr FMULP - = uppPStr SLIT("\tfmulp") + = ptext SLIT("\tfmulp") pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op -pprInstr FCHS = uppPStr SLIT("\tfchs") +pprInstr FCHS = ptext SLIT("\tfchs") pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op -pprInstr FCOS = uppPStr SLIT("\tfcos") +pprInstr FCOS = ptext SLIT("\tfcos") pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op pprInstr (FDIV sz src) - = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppSP, pprOperand sz src] + = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src] pprInstr FDIVP - = uppPStr SLIT("\tfdivp") + = ptext SLIT("\tfdivp") pprInstr (FDIVR sz src) - = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppSP, pprOperand sz src] + = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src] pprInstr FDIVRP - = uppPStr SLIT("\tfdivpr") + = ptext SLIT("\tfdivpr") pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op pprInstr (FLD sz (OpImm (ImmCLbl src))) - = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprCLabel_asm src] + = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src] pprInstr (FLD sz src) - = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppSP,pprOperand sz src] -pprInstr FLD1 = uppPStr SLIT("\tfld1") -pprInstr FLDZ = uppPStr SLIT("\tfldz") + = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src] +pprInstr FLD1 = ptext SLIT("\tfld1") +pprInstr FLDZ = ptext SLIT("\tfldz") pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op -pprInstr FRNDINT = uppPStr SLIT("\tfrndint") -pprInstr FSIN = uppPStr SLIT("\tfsin") -pprInstr FSQRT = uppPStr SLIT("\tfsqrt") +pprInstr FRNDINT = ptext SLIT("\tfrndint") +pprInstr FSIN = ptext SLIT("\tfsin") +pprInstr FSQRT = ptext SLIT("\tfsqrt") pprInstr (FST sz dst) - = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppSP, pprOperand sz dst] + = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst] pprInstr (FSTP sz dst) - = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppSP, pprOperand sz dst] + = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst] pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op pprInstr (FSUB sz src) - = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppSP, pprOperand sz src] + = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src] pprInstr FSUBP - = uppPStr SLIT("\tfsubp") + = ptext SLIT("\tfsubp") pprInstr (FSUBR size src) = pprSizeOp SLIT("fsubr") size src pprInstr FSUBRP - = uppPStr SLIT("\tfsubpr") + = ptext SLIT("\tfsubpr") pprInstr (FISUBR size op) = pprSizeAddr SLIT("fisubr") size op -pprInstr FTST = uppPStr SLIT("\tftst") +pprInstr FTST = ptext SLIT("\tftst") pprInstr (FCOMP sz op) - = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppSP, pprOperand sz op] -pprInstr FUCOMPP = uppPStr SLIT("\tfucompp") -pprInstr FXCH = uppPStr SLIT("\tfxch") -pprInstr FNSTSW = uppPStr SLIT("\tfnstsw %ax") -pprInstr FNOP = uppPStr SLIT("") + = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op] +pprInstr FUCOMPP = ptext SLIT("\tfucompp") +pprInstr FXCH = ptext SLIT("\tfxch") +pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax") +pprInstr FNOP = ptext SLIT("") \end{code} Continue with I386-only printing bits and bobs: \begin{code} -pprDollImm :: Imm -> Unpretty +pprDollImm :: Imm -> Doc -pprDollImm i = uppBesides [ uppPStr SLIT("$"), pprImm i] +pprDollImm i = hcat [ ptext SLIT("$"), pprImm i] -pprOperand :: Size -> Operand -> Unpretty +pprOperand :: Size -> Operand -> Doc pprOperand s (OpReg r) = pprReg s r pprOperand s (OpImm i) = pprDollImm i pprOperand s (OpAddr ea) = pprAddr ea -pprSizeOp :: FAST_STRING -> Size -> Operand -> Unpretty +pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc pprSizeOp name size op1 - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppSP, + space, pprOperand size op1 ] -pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc pprSizeOpOp name size op1 op2 - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppSP, + space, pprOperand size op1, - uppComma, + comma, pprOperand size op2 ] -pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Unpretty +pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc pprSizeOpReg name size op1 reg - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppSP, + space, pprOperand size op1, - uppComma, + comma, pprReg size reg ] -pprSizeAddr :: FAST_STRING -> Size -> Addr -> Unpretty +pprSizeAddr :: FAST_STRING -> Size -> Addr -> Doc pprSizeAddr name size op - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppSP, + space, pprAddr op ] -pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Unpretty +pprSizeAddrReg :: FAST_STRING -> Size -> Addr -> Reg -> Doc pprSizeAddrReg name size op dst - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, pprSize size, - uppSP, + space, pprAddr op, - uppComma, + comma, pprReg size dst ] -pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Unpretty +pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc pprOpOp name size op1 op2 - = uppBesides [ - uppChar '\t', - uppPStr name, uppSP, + = hcat [ + char '\t', + ptext name, space, pprOperand size op1, - uppComma, + comma, pprOperand size op2 ] -pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty +pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc pprSizeOpOpCoerce name size1 size2 op1 op2 - = uppBesides [ uppChar '\t', uppPStr name, uppSP, + = hcat [ char '\t', ptext name, space, pprOperand size1 op1, - uppComma, + comma, pprOperand size2 op2 ] -pprCondInstr :: FAST_STRING -> Cond -> Unpretty -> Unpretty +pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc pprCondInstr name cond arg - = uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppSP, arg] + = hcat [ char '\t', ptext name, pprCond cond, space, arg] #endif {-i386_TARGET_ARCH-} \end{code} @@ -1100,13 +1122,13 @@ pprCondInstr name cond arg -- a clumsy hack for now, to handle possible double alignment problems pprInstr (LD DF addr reg) | maybeToBool off_addr - = uppBesides [ + = hcat [ pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg, - uppChar '\n', + char '\n', pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma, @@ -1117,11 +1139,11 @@ pprInstr (LD DF addr reg) | maybeToBool off_addr addr2 = case off_addr of Just x -> x pprInstr (LD size addr reg) - = uppBesides [ - uppPStr SLIT("\tld"), + = hcat [ + ptext SLIT("\tld"), pprSize size, - uppChar '\t', - uppLbrack, + char '\t', + lbrack, pprAddr addr, pp_rbracket_comma, pprReg reg @@ -1130,44 +1152,48 @@ pprInstr (LD size addr reg) -- The same clumsy hack as above pprInstr (ST DF reg addr) | maybeToBool off_addr - = uppBesides [ - uppPStr SLIT("\tst\t"), + = hcat [ + ptext SLIT("\tst\t"), pprReg reg, pp_comma_lbracket, pprAddr addr, - uppPStr SLIT("]\n\tst\t"), + ptext SLIT("]\n\tst\t"), pprReg (fPair reg), pp_comma_lbracket, pprAddr addr2, - uppRbrack + rbrack ] where off_addr = addrOffset addr 4 addr2 = case off_addr of Just x -> x +-- no distinction is made between signed and unsigned bytes on stores for the +-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), +-- so we call a special-purpose pprSize for ST.. + pprInstr (ST size reg addr) - = uppBesides [ - uppPStr SLIT("\tst"), - pprSize size, - uppChar '\t', + = hcat [ + ptext SLIT("\tst"), + pprStSize size, + char '\t', pprReg reg, pp_comma_lbracket, pprAddr addr, - uppRbrack + rbrack ] pprInstr (ADD x cc reg1 ri reg2) | not x && not cc && riZero ri - = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ] + = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ] | otherwise = pprRegRIReg (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2 pprInstr (SUB x cc reg1 ri reg2) | not x && cc && reg2 == g0 - = uppBesides [ uppPStr SLIT("\tcmp\t"), pprReg reg1, uppComma, pprRI ri ] + = hcat [ ptext SLIT("\tcmp\t"), pprReg reg1, comma, pprRI ri ] | not x && not cc && riZero ri - = uppBesides [ uppPStr SLIT("\tmov\t"), pprReg reg1, uppComma, pprReg reg2 ] + = hcat [ ptext SLIT("\tmov\t"), pprReg reg1, comma, pprReg reg2 ] | otherwise = pprRegRIReg (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2 @@ -1176,7 +1202,7 @@ pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg SLIT("andn") b reg1 ri reg2 pprInstr (OR b reg1 ri reg2) | not b && reg1 == g0 - = uppBesides [ uppPStr SLIT("\tmov\t"), pprRI ri, uppComma, pprReg reg2 ] + = hcat [ ptext SLIT("\tmov\t"), pprRI ri, comma, pprReg reg2 ] | otherwise = pprRegRIReg SLIT("or") b reg1 ri reg2 @@ -1190,20 +1216,20 @@ pprInstr (SRL reg1 ri reg2) = pprRegRIReg SLIT("srl") False reg1 ri reg2 pprInstr (SRA reg1 ri reg2) = pprRegRIReg SLIT("sra") False reg1 ri reg2 pprInstr (SETHI imm reg) - = uppBesides [ - uppPStr SLIT("\tsethi\t"), + = hcat [ + ptext SLIT("\tsethi\t"), pprImm imm, - uppComma, + comma, pprReg reg ] -pprInstr NOP = uppPStr SLIT("\tnop") +pprInstr NOP = ptext SLIT("\tnop") pprInstr (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2 pprInstr (FABS DF reg1 reg2) - = uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') + = (<>) (pprSizeRegReg SLIT("fabs") F reg1 reg2) + (if (reg1 == reg2) then empty + else (<>) (char '\n') (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) pprInstr (FADD size reg1 reg2 reg3) @@ -1215,9 +1241,9 @@ pprInstr (FDIV size reg1 reg2 reg3) pprInstr (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2 pprInstr (FMOV DF reg1 reg2) - = uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') + = (<>) (pprSizeRegReg SLIT("fmov") F reg1 reg2) + (if (reg1 == reg2) then empty + else (<>) (char '\n') (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) pprInstr (FMUL size reg1 reg2 reg3) @@ -1225,114 +1251,114 @@ pprInstr (FMUL size reg1 reg2 reg3) pprInstr (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2 pprInstr (FNEG DF reg1 reg2) - = uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2) - (if (reg1 == reg2) then uppNil - else uppBeside (uppChar '\n') + = (<>) (pprSizeRegReg SLIT("fneg") F reg1 reg2) + (if (reg1 == reg2) then empty + else (<>) (char '\n') (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2))) pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2 pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3 pprInstr (FxTOy size1 size2 reg1 reg2) - = uppBesides [ - uppPStr SLIT("\tf"), - uppPStr + = hcat [ + ptext SLIT("\tf"), + ptext (case size1 of W -> SLIT("ito") F -> SLIT("sto") DF -> SLIT("dto")), - uppPStr + ptext (case size2 of W -> SLIT("i\t") F -> SLIT("s\t") DF -> SLIT("d\t")), - pprReg reg1, uppComma, pprReg reg2 + pprReg reg1, comma, pprReg reg2 ] pprInstr (BI cond b lab) - = uppBesides [ - uppPStr SLIT("\tb"), pprCond cond, - if b then pp_comma_a else uppNil, - uppChar '\t', + = hcat [ + ptext SLIT("\tb"), pprCond cond, + if b then pp_comma_a else empty, + char '\t', pprImm lab ] pprInstr (BF cond b lab) - = uppBesides [ - uppPStr SLIT("\tfb"), pprCond cond, - if b then pp_comma_a else uppNil, - uppChar '\t', + = hcat [ + ptext SLIT("\tfb"), pprCond cond, + if b then pp_comma_a else empty, + char '\t', pprImm lab ] -pprInstr (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr addr) +pprInstr (JMP addr) = (<>) (ptext SLIT("\tjmp\t")) (pprAddr addr) pprInstr (CALL imm n _) - = uppBesides [ uppPStr SLIT("\tcall\t"), pprImm imm, uppComma, uppInt n ] + = hcat [ ptext SLIT("\tcall\t"), pprImm imm, comma, int n ] \end{code} Continue with SPARC-only printing bits and bobs: \begin{code} -pprRI :: RI -> Unpretty +pprRI :: RI -> Doc pprRI (RIReg r) = pprReg r pprRI (RIImm r) = pprImm r -pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty +pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc pprSizeRegReg name size reg1 reg2 - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, (case size of - F -> uppPStr SLIT("s\t") - DF -> uppPStr SLIT("d\t")), + F -> ptext SLIT("s\t") + DF -> ptext SLIT("d\t")), pprReg reg1, - uppComma, + comma, pprReg reg2 ] -pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty +pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc pprSizeRegRegReg name size reg1 reg2 reg3 - = uppBesides [ - uppChar '\t', - uppPStr name, + = hcat [ + char '\t', + ptext name, (case size of - F -> uppPStr SLIT("s\t") - DF -> uppPStr SLIT("d\t")), + F -> ptext SLIT("s\t") + DF -> ptext SLIT("d\t")), pprReg reg1, - uppComma, + comma, pprReg reg2, - uppComma, + comma, pprReg reg3 ] -pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty +pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc pprRegRIReg name b reg1 ri reg2 - = uppBesides [ - uppChar '\t', - uppPStr name, - if b then uppPStr SLIT("cc\t") else uppChar '\t', + = hcat [ + char '\t', + ptext name, + if b then ptext SLIT("cc\t") else char '\t', pprReg reg1, - uppComma, + comma, pprRI ri, - uppComma, + comma, pprReg reg2 ] -pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Unpretty +pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc pprRIReg name b ri reg1 - = uppBesides [ - uppChar '\t', - uppPStr name, - if b then uppPStr SLIT("cc\t") else uppChar '\t', + = hcat [ + char '\t', + ptext name, + if b then ptext SLIT("cc\t") else char '\t', pprRI ri, - uppComma, + comma, pprReg reg1 ] -pp_ld_lbracket = uppPStr (pACK_STR (a_HASH "\tld\t["#)) -pp_rbracket_comma = uppPStr (pACK_STR (a_HASH "],"#)) -pp_comma_lbracket = uppPStr (pACK_STR (a_HASH ",["#)) -pp_comma_a = uppPStr (pACK_STR (a_HASH ",a"#)) +pp_ld_lbracket = ptext (pACK_STR (a_HASH "\tld\t["#)) +pp_rbracket_comma = ptext (pACK_STR (a_HASH "],"#)) +pp_comma_lbracket = ptext (pACK_STR (a_HASH ",["#)) +pp_comma_a = ptext (pACK_STR (a_HASH ",a"#)) #endif {-sparc_TARGET_ARCH-} \end{code} diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 22a7618..be0d40d 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -51,7 +51,15 @@ module RegAllocInfo ( freeRegSet ) where +#if __GLASGOW_HASKELL__ >= 202 +import qualified GlaExts (Addr(..)) +import GlaExts hiding (Addr(..)) +import FastString +import Ubiq +#else IMP_Ubiq(){-uitous-} +import Pretty ( Doc ) +#endif IMPORT_1_3(List(partition)) import MachMisc @@ -66,7 +74,6 @@ import OrdList ( mkUnitList, OrdList ) import PrimRep ( PrimRep(..) ) import Stix ( StixTree, CodeSegment ) import UniqSet -- quite a bit of it -import Unpretty ( uppShow ) \end{code} %************************************************************************ @@ -533,7 +540,7 @@ regLiveness instr info@(RL live future@(FL all env)) lookup lbl = case (lookupFM env lbl) of Just rs -> rs - Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel_asm lbl)) ++ + Nothing -> trace ("Missing " ++ (show (pprCLabel_asm lbl)) ++ " in future?") emptyRegSet in case instr of -- the rest is machine-specific... diff --git a/ghc/compiler/nativeGen/Stix.hi-boot b/ghc/compiler/nativeGen/Stix.hi-boot new file mode 100644 index 0000000..76cfdab --- /dev/null +++ b/ghc/compiler/nativeGen/Stix.hi-boot @@ -0,0 +1,5 @@ +_interface_ Stix 1 +_exports_ +Stix StixTree; +_declarations_ +1 data StixTree; diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 10521a3..1dbd660 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -20,9 +20,12 @@ IMPORT_1_3(Ratio(Rational)) import AbsCSyn ( node, infoptr, MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) -import CLabel ( mkAsmTempLabel ) +import CLabel ( mkAsmTempLabel, CLabel ) +import PrimRep ( PrimRep ) +import PrimOp ( PrimOp ) +import Unique ( Unique ) import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) ) -import Unpretty ( uppPStr, SYN_IE(Unpretty) ) +import Pretty ( ptext, Doc ) \end{code} Here is the tag at the nodes of our @StixTree@. Notice its @@ -39,7 +42,7 @@ data StixTree | StInt Integer -- ** add Kind at some point | StDouble Rational | StString FAST_STRING - | StLitLbl Unpretty -- literal labels + | StLitLbl Doc -- literal labels -- (will be _-prefixed on some machines) | StLitLit FAST_STRING -- innards from CLitLit | StCLbl CLabel -- labels that we might index into @@ -100,7 +103,7 @@ data StixTree | StComment FAST_STRING sStLitLbl :: FAST_STRING -> StixTree -sStLitLbl s = StLitLbl (uppPStr s) +sStLitLbl s = StLitLbl (ptext s) \end{code} Stix registers can have two forms. They {\em may} or {\em may not} diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 150dc41..56daf99 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -26,7 +26,7 @@ import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), import Stix -- all of it import StixPrim ( amodeToStix ) import UniqSupply ( returnUs, SYN_IE(UniqSM) ) -import Unpretty ( uppBesides, uppPStr, uppInt, uppChar ) +import Pretty ( hcat, ptext, int, char ) \end{code} Generating code for info tables (arrays of data). @@ -79,21 +79,21 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ upd cl_descr _) tag] SpecialisedRep _ _ _ updatable -> - let rtbl = uppBesides ( + let rtbl = hcat ( if is_selector then - [uppPStr SLIT("Select__"), - uppInt select_word, - uppPStr SLIT("_rtbl")] + [ptext SLIT("Select__"), + int select_word, + ptext SLIT("_rtbl")] else - [uppPStr (case updatable of + [ptext (case updatable of SMNormalForm -> SLIT("Spec_N_") SMSingleEntry -> SLIT("Spec_S_") SMUpdatable -> SLIT("Spec_U_") ), - uppInt size, - uppChar '_', - uppInt ptrs, - uppPStr SLIT("_rtbl")]) + int size, + char '_', + int ptrs, + ptext SLIT("_rtbl")]) in case updatable of SMNormalForm -> [upd_code, StLitLbl rtbl, tag] diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 45e11d8..d4be4d5 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -15,7 +15,11 @@ IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) import MachMisc +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import AbsCSyn -- bits and bobs... import Constants ( mIN_MP_INT_SIZE ) diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 664b2df..5333c3c 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -11,7 +11,11 @@ IMP_Ubiq(){-uitious-} IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) import MachMisc +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode ) import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE, diff --git a/ghc/compiler/nativeGen/StixPrim.hi-boot b/ghc/compiler/nativeGen/StixPrim.hi-boot new file mode 100644 index 0000000..1df7a8c --- /dev/null +++ b/ghc/compiler/nativeGen/StixPrim.hi-boot @@ -0,0 +1,5 @@ +_interface_ StixPrim 1 +_exports_ +StixPrim amodeToStix; +_declarations_ +1 amodeToStix _:_ AbsCSyn.CAddrMode -> Stix.StixTree ;; diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 14bc255..ad04c1d 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -11,7 +11,11 @@ IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(NcgLoop) -- paranoia checking only import MachMisc +#if __GLASGOW_HASKELL__ >= 202 +import MachRegs hiding (Addr) +#else import MachRegs +#endif import AbsCSyn import AbsCUtils ( getAmodeRep, mixedTypeLocn ) @@ -30,7 +34,7 @@ import Stix import StixMacro ( heapCheck ) import StixInteger {- everything -} import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) -import Unpretty ( uppBeside, uppPStr, uppInt ) +import Pretty ( (<>), ptext, int ) import Util ( panic ) #ifdef REALLY_HASKELL_1_3 @@ -233,7 +237,7 @@ primCode [lhs] ReadArrayOp [obj, ix] in returnUs (\xs -> assign : xs) -primCode [lhs] WriteArrayOp [obj, ix, v] +primCode [] WriteArrayOp [obj, ix, v] = let obj' = amodeToStix obj ix' = amodeToStix ix @@ -469,7 +473,7 @@ simplePrim [lhs] op rest ReturnsPrim pk -> pk _ -> simplePrim_error op -simplePrim _ op _ = simplePrim_error op +simplePrim as op bs = simplePrim_error op simplePrim_error op = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n") @@ -523,7 +527,7 @@ amodeToStix (CTableEntry base off pk) -- For CharLike and IntLike, we attempt some trivial constant-folding here. amodeToStix (CCharLike (CLit (MachChar c))) - = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off)) where off = charLikeSize * ord c diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index b9edb42..b17b849 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -24,7 +24,11 @@ module UgenAll ( EXP_MODULE(U_ttype) ) where +#if __GLASGOW_HASKELL__ <= 201 import PreludeGlaST +#else +import GlaExts +#endif IMP_Ubiq(){-uitous-} diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 944b217..bb0d68e 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -14,12 +14,21 @@ module UgenUtil ( IMP_Ubiq() +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 import PreludeGlaST +#else +import GlaExts +import Name +#endif -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 # define ADDR GHCbase.Addr # define PACK_STR packCString # define PACK_BYTES packCBytes +#elif __GLASGOW_HASKELL >= 202 +# define ADDR GHC.Addr +# define PACK_STR mkFastCharString +# define PACK_BYTES mkFastCharString2 #else # define ADDR _Addr # define PACK_STR mkFastCharString diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn index 30cd438..65b5b67 100644 --- a/ghc/compiler/parser/constr.ugn +++ b/ghc/compiler/parser/constr.ugn @@ -35,6 +35,10 @@ type constr; gconnty : ttype; gconnline : long; >; + /* constr with a prefixed context C => ... */ + constrcxt : < gconcxt : list; + gconcon : constr; >; + field : < gfieldn : list; gfieldt : ttype; >; end; diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 77351a0..4ca10ea 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -236,7 +236,7 @@ BOOLEAN inpat; maybefixes fixes fix ops dtyclses dtycls_list gdrhs gdpat valrhs - lampats cexps + lampats cexps gd %type maybeexports impspec deriving @@ -244,7 +244,7 @@ BOOLEAN inpat; %type exp oexp dexp kexp fexp aexp rbind texps expL oexpL kexpL expLno oexpLno dexpLno kexpLno - vallhs funlhs qual gd leftexp + vallhs funlhs qual leftexp pat cpat bpat apat apatc conpat rpat patk bpatk apatck conpatk @@ -269,12 +269,12 @@ BOOLEAN inpat; %type valrhs1 altrest -%type simple ctype type atype btype +%type simple ctype sigtype sigarrowtype type atype bigatype btype gtyconvars - bbtype batype bxtype bang_atype - class tyvar + bbtype batype bxtype wierd_atype + class tyvar contype -%type constr field +%type constr constr_after_context field %type FLOAT INTEGER INTPRIM FLOATPRIM DOUBLEPRIM CLITLIT @@ -570,7 +570,7 @@ decls : decl to real mischief (ugly, but likely to work). */ -decl : qvarsk DCOLON ctype +decl : qvarsk DCOLON sigtype { $$ = mksbind($1,$3,startlineno); PREVPATT = NULL; FN = NULL; SAMEFN = 0; } @@ -662,18 +662,34 @@ type_and_maybe_id : context. Blaach! */ +/* A sigtype is a rank 2 type; it can have for-alls as function args: + f :: All a => (All b => ...) -> Int +*/ +sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); } + | sigarrowtype + ; + +sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); } + | btype RARROW sigarrowtype { $$ = mktfun($1,$3); } + | btype + ; + +/* A "big" atype can be a forall-type in brackets. */ +bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); } + ; + /* 1 S/R conflict at DARROW -> shift */ ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); } | type ; /* 1 S/R conflict at RARROW -> shift */ -type : btype { $$ = $1; } - | btype RARROW type { $$ = mktfun($1,$3); } +type : btype RARROW type { $$ = mktfun($1,$3); } + | btype { $$ = $1; } ; -btype : atype { $$ = $1; } - | btype atype { $$ = mktapp($1,$2); } +btype : btype atype { $$ = mktapp($1,$2); } + | atype { $$ = $1; } ; atype : gtycon { $$ = mktname($1); } @@ -733,12 +749,11 @@ constrs : constr { $$ = lsing($1); } | constrs VBAR constr { $$ = lapp($1,$3); } ; -constr : btype { qid tyc; list tys; - splittyconapp($1, &tyc, &tys); - $$ = mkconstrpre(tyc,tys,hsplineno); } - | bxtype { qid tyc; list tys; - splittyconapp($1, &tyc, &tys); - $$ = mkconstrpre(tyc,tys,hsplineno); } +constr : constr_after_context + | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); } + ; + +constr_after_context : /* We have to parse the constructor application as a *type*, else we get into terrible ambiguity problems. Consider the difference between @@ -752,31 +767,50 @@ constr : btype { qid tyc; list tys; second. */ - | btype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } - | bang_atype qconop bbtype { $$ = mkconstrinf( $1, $2, $3, hsplineno ); } +/* Con !Int (Tree a) */ + contype { qid tyc; list tys; + splittyconapp($1, &tyc, &tys); + $$ = mkconstrpre(tyc,tys,hsplineno); } +/* !Int `Con` Tree a */ + | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); } +/* (::) (Tree a) Int */ | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); } + +/* Con { op1 :: Int } */ | gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); } /* 1 S/R conflict on OCURLY -> shift */ ; -/* S !Int Bool */ -bxtype : btype bang_atype { $$ = mktapp($1, $2); } - | bxtype bbtype { $$ = mktapp($1, $2); } + +/* contype has to reduce to a btype unless there are !'s, so that + we don't get reduce/reduce conflicts with the second production of constr. + But as soon as we see a ! we must switch to using bxtype. */ + +contype : btype { $$ = $1 } + | bxtype { $$ = $1 } ; +/* S !Int Bool; at least one ! */ +bxtype : btype wierd_atype { $$ = mktapp($1, $2); } + | bxtype batype { $$ = mktapp($1, $2); } + ; bbtype : btype { $$ = $1; } - | bang_atype { $$ = $1; } + | wierd_atype { $$ = $1; } ; batype : atype { $$ = $1; } - | bang_atype { $$ = $1; } + | wierd_atype { $$ = $1; } ; -bang_atype : BANG atype { $$ = mktbang( $2 ) } - ; +/* A wierd atype is one that isn't a regular atype; + it starts with a "!", or with a forall. */ +wierd_atype : BANG bigatype { $$ = mktbang( $2 ) } + | BANG atype { $$ = mktbang( $2 ) } + | bigatype + ; batypes : { $$ = Lnil; } | batypes batype { $$ = lapp($1,$2); } @@ -787,8 +821,9 @@ fields : field { $$ = lsing($1); } | fields COMMA field { $$ = lapp($1,$3); } ; -field : qvars_list DCOLON type { $$ = mkfield($1,$3); } +field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); } | qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); } + | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); } ; constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); } @@ -912,7 +947,7 @@ maybe_where: | /* empty */ { $$ = mknullbind(); } ; -gd : VBAR oexp { $$ = $2; } +gd : VBAR quals { $$ = $2; } ; @@ -1130,7 +1165,8 @@ quals : qual { $$ = lsing($1); } qual : letdecls { $$ = mkseqlet($1); } | expL { $$ = $1; } - | {inpat=TRUE;} expLno {inpat=FALSE;}leftexp + | {inpat=TRUE;} expLno + {inpat=FALSE;} leftexp { if ($4 == NULL) { expORpat(LEGIT_EXPR,$2); $$ = mkguard($2); diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn index f695eac..2d734ea 100644 --- a/ghc/compiler/parser/pbinding.ugn +++ b/ghc/compiler/parser/pbinding.ugn @@ -26,6 +26,7 @@ type pbinding; pnoguards : < gpnoguard : tree; >; pguards : < gpguards : list; >; - pgdexp : < gpguard : tree; + + pgdexp : < gpguard : list; /* Experimental change: guards are lists of quals */ gpexp : tree; >; end; diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c index a48b119..4194377 100644 --- a/ghc/compiler/parser/syntax.c +++ b/ghc/compiler/parser/syntax.c @@ -127,6 +127,7 @@ expORpat(int wanted, tree e) case clitlit: error_if_patt_wanted(wanted, "``literal-literal'' in pattern"); + break; default: /* the others only occur in pragmas */ hsperror("not a valid literal pattern or expression"); diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 426eb62..665aa92 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -15,7 +15,7 @@ module PrelInfo ( eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, - enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR, + enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR, ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, @@ -27,14 +27,18 @@ module PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR, - main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME, + main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME, allClass_NAME, - needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass, + needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass ) where IMP_Ubiq() +#if __GLASGOW_HASKELL__ >= 202 +import IdUtils ( primOpName ) +#else IMPORT_DELOOPER(PrelLoop) ( primOpName ) +#endif -- IMPORT_DELOOPER(IdLoop) ( SpecEnv ) -- friends: @@ -56,7 +60,7 @@ import TyCon ( tyConDataCons, mkFunTyCon, TyCon ) import Type import Bag import Unique -- *Key stuff -import UniqFM ( UniqFM, listToUFM ) +import UniqFM ( UniqFM, listToUFM, Uniquable(..) ) import Util ( isIn ) \end{code} @@ -248,6 +252,7 @@ Ids, Synonyms, Classes and ClassOps with builtin keys. mkKnownKeyGlobal :: (RdrName, Unique) -> Name mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit +allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey) main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey) ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey) @@ -255,14 +260,18 @@ primIoTyCon_NAME = getName primIoTyCon knownKeyNames :: [Name] knownKeyNames - = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME] + = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME, allClass_NAME] ++ map mkKnownKeyGlobal [ -- Type constructors (synonyms especially) (orderingTyCon_RDR, orderingTyConKey) , (rationalTyCon_RDR, rationalTyConKey) + , (ratioDataCon_RDR, ratioDataConKey) , (ratioTyCon_RDR, ratioTyConKey) + , (byteArrayTyCon_RDR, byteArrayTyConKey) + , (mutableByteArrayTyCon_RDR, mutableByteArrayTyConKey) + -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) @@ -336,7 +345,12 @@ ioTyCon_RDR = tcQual (iO_BASE, SLIT("IO")) orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering")) rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational")) ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio")) +ratioDataCon_RDR = varQual (pREL_NUM, SLIT(":%")) + +byteArrayTyCon_RDR = tcQual (aRR_BASE, SLIT("ByteArray")) +mutableByteArrayTyCon_RDR = tcQual (aRR_BASE, SLIT("MutableByteArray")) +allClass_RDR = tcQual (gHC__, SLIT("All")) eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq")) ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord")) evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval")) @@ -372,7 +386,7 @@ enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo")) thenM_RDR = varQual (pREL_BASE, SLIT(">>=")) returnM_RDR = varQual (pREL_BASE, SLIT("return")) zeroM_RDR = varQual (pREL_BASE, SLIT("zero")) -fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) +fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational")) negate_RDR = varQual (pREL_BASE, SLIT("negate")) eq_RDR = varQual (pREL_BASE, SLIT("==")) @@ -468,7 +482,9 @@ derivableClassKeys = map fst deriving_occ_info deriving_occ_info = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR]) - , (ordClassKey, [intTyCon_RDR, compose_RDR]) + , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR]) + -- EQ (from Ordering) is needed to force in the constructors + -- as well as the type constructor. , (enumClassKey, [intTyCon_RDR, map_RDR]) , (evalClassKey, [intTyCon_RDR]) , (boundedClassKey, [intTyCon_RDR]) @@ -514,6 +530,10 @@ needsDataDeclCtxtClassKeys -- see comments in TcDeriv cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] + -- Renamer always imports these data decls replete with constructors + -- so that desugarer can always see the constructor. Ugh! +cCallishTyKeys = [ addrTyConKey, wordTyConKey, byteArrayTyConKey, mutableByteArrayTyConKey ] + standardClassKeys = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys -- diff --git a/ghc/compiler/prelude/PrelLoop.hs b/ghc/compiler/prelude/PrelLoop.hs new file mode 100644 index 0000000..867db08 --- /dev/null +++ b/ghc/compiler/prelude/PrelLoop.hs @@ -0,0 +1 @@ +module PrelLoop where diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 321b83c..ed6c186 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -14,8 +14,6 @@ defined here so as to avod module PrelMods ( - isPreludeModule, -- :: Module -> Bool - gHC__, pRELUDE, pREL_BASE, pREL_READ , pREL_NUM, pREL_LIST, pREL_TUP , pACKED_STRING, cONC_BASE, @@ -33,9 +31,6 @@ Predicate used by RnIface to decide whether or not to append a special suffix for prelude modules: \begin{code} -isPreludeModule :: Module -> Bool -isPreludeModule mod = mod `elementOfUniqSet` preludeNames - preludeNames :: UniqSet FAST_STRING preludeNames = mkUniqSet diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 046e6fa..5cea888 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -9,7 +9,7 @@ module PrelVals where IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv ) +IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), mkUnfolding, nullSpecEnv, SpecEnv ) import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals ) IMPORT_DELOOPER(PrelLoop) @@ -23,17 +23,24 @@ import CmdLineOpts ( maybe_CompilingGhcInternals ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) -import Name ( mkWiredInIdName ) +import Name ( mkWiredInIdName, SYN_IE(Module) ) import PragmaInfo import PrimOp ( PrimOp(..) ) +#if __GLASGOW_HASKELL__ >= 202 +import Type +#else import Type ( mkTyVarTy ) -import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar ) +#endif +import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar, SYN_IE(TyVar) ) import Unique -- lots of *Keys import Util ( panic ) \end{code} \begin{code} -- only used herein: + +mk_inline_unfolding = mkUnfolding IWantToBeINLINEd + pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id pcMiscPrelId key mod occ ty info @@ -211,7 +218,7 @@ integerMinusOneId seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template)) where [x, y, z] = mkTemplateLocals [ @@ -246,7 +253,7 @@ seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq") parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template)) where [x, y, z] = mkTemplateLocals [ @@ -269,7 +276,7 @@ parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par") forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template)) where [x, y, z] = mkTemplateLocals [ @@ -293,7 +300,7 @@ GranSim ones: parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, x, y, z] @@ -317,7 +324,7 @@ parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal") parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, x, y, z] @@ -343,7 +350,7 @@ parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -368,7 +375,7 @@ parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt") parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -393,7 +400,7 @@ parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs") parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -419,7 +426,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy, gammaTy] gammaTy)) - (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template)) where -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL [w, g, s, p, v, x, y, z] @@ -447,7 +454,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable") (mkSigmaTy [alphaTyVar] [] alphaTy) - (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template)) where -- Annotations: x: closure that's tagged to by copyable [x, z] @@ -462,7 +469,7 @@ copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable") noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow") (mkSigmaTy [alphaTyVar] [] alphaTy) - (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template)) + (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template)) where -- Annotations: x: closure that's tagged to not follow [x, z] @@ -511,7 +518,7 @@ runSTId `addArityInfo` exactArity 1 `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1] - -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template) + -- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template) -- see example below {- OUT: [m, t, r, wild] diff --git a/ghc/compiler/prelude/PrimOp.hi-boot b/ghc/compiler/prelude/PrimOp.hi-boot new file mode 100644 index 0000000..f20484a --- /dev/null +++ b/ghc/compiler/prelude/PrimOp.hi-boot @@ -0,0 +1,5 @@ +_interface_ PrimOp 1 +_exports_ +PrimOp PrimOp; +_declarations_ +1 data PrimOp; diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7ba7dd3..53a19cd 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -38,17 +38,20 @@ import TysWiredIn import CStrings ( identToC ) import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) -import PprStyle ( codeStyle, ifaceStyle ) +import PprStyle --( codeStyle, ifaceStyle ) import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) import TyCon ( TyCon{-instances-} ) -import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts, +import Type {- ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts, mkForAllTys, mkFunTy, mkFunTys, applyTyCon, typePrimRep - ) -import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) + ) -} +import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) import Util ( panic#, assoc, panic{-ToDo:rm-} ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} %************************************************************************ @@ -766,6 +769,7 @@ primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy +primOpInfo IntAbsOp = Monadic SLIT("absInt#") intPrimTy \end{code} %************************************************************************ @@ -1771,11 +1775,10 @@ compare_fun_ty ty = mkFunTys [ty, ty] boolTy Output stuff: \begin{code} -pprPrimOp :: PprStyle -> PrimOp -> Pretty +pprPrimOp :: PprStyle -> PrimOp -> Doc showPrimOp :: PprStyle -> PrimOp -> String -showPrimOp sty op - = ppShow 1000{-random-} (pprPrimOp sty op) +showPrimOp sty op = render (pprPrimOp sty op) pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) = let @@ -1786,22 +1789,22 @@ pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) if may_gc then "_ccall_GC_ " else "_ccall_ " after - = if is_casm then ppStr "''" else ppNil + = if is_casm then text "''" else empty pp_tys - = ppCat (map (pprParendGenType sty) (res_ty:arg_tys)) + = hsep (map (pprParendGenType sty) (res_ty:arg_tys)) in - ppBesides [ppStr before, ppPStr fun, after, ppSP, ppLbrack, pp_tys, ppRbrack] + hcat [text before, ptext fun, after, space, brackets pp_tys] pprPrimOp sty other_op | codeStyle sty -- For C just print the primop itself = identToC str | ifaceStyle sty -- For interfaces Print it qualified with GHC. - = ppPStr SLIT("GHC.") `ppBeside` ppPStr str + = ptext SLIT("GHC.") <> ptext str | otherwise -- Unqualified is good enough - = ppPStr str + = ptext str where str = primOp_str other_op diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 387f70d..4b1b71c 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -23,7 +23,11 @@ IMP_Ubiq() import Pretty -- pretty-printing code import Util +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif +-- Oh dear. #include "../../includes/GhcConstants.h" \end{code} @@ -146,17 +150,17 @@ retPrimRepSize = getPrimRepSize RetRep \begin{code} instance Outputable PrimRep where - ppr sty kind = ppStr (showPrimRep kind) + ppr sty kind = text (showPrimRep kind) showPrimRep :: PrimRep -> String -- dumping PrimRep tag for unfoldings -ppPrimRep :: PrimRep -> Pretty +ppPrimRep :: PrimRep -> Doc guessPrimRep :: String -> PrimRep -- a horrible "inverse" function decodePrimRep :: Char -> PrimRep -- of equal nature ppPrimRep k = - ppChar + char (case k of PtrRep -> 'P' CodePtrRep -> 'p' diff --git a/ghc/compiler/prelude/StdIdInfo.hi-boot b/ghc/compiler/prelude/StdIdInfo.hi-boot new file mode 100644 index 0000000..680b7f1 --- /dev/null +++ b/ghc/compiler/prelude/StdIdInfo.hi-boot @@ -0,0 +1,5 @@ +_interface_ StdIdInfo 1 +_exports_ +StdIdInfo addStandardIdInfo; +_declarations_ +1 addStandardIdInfo _:_ Id.Id -> Id.Id ;; diff --git a/ghc/compiler/prelude/StdIdInfo.lhs b/ghc/compiler/prelude/StdIdInfo.lhs index a13fa83..d968566 100644 --- a/ghc/compiler/prelude/StdIdInfo.lhs +++ b/ghc/compiler/prelude/StdIdInfo.lhs @@ -23,7 +23,7 @@ IMP_Ubiq() import Type import CoreSyn import Literal -import CoreUnfold ( mkUnfolding ) +import CoreUnfold ( mkUnfolding, PragmaInfo(..) ) import TysWiredIn ( tupleCon ) import Id ( GenId, mkTemplateLocals, idType, dataConStrictMarks, dataConFieldLabels, dataConArgTys, @@ -31,7 +31,8 @@ import Id ( GenId, mkTemplateLocals, idType, StrictnessMark(..), isDataCon, isMethodSelId_maybe, isSuperDictSelId_maybe, isRecordSelector, isPrimitiveId_maybe, - addIdUnfolding, addIdArity + addIdUnfolding, addIdArity, + SYN_IE(Id) ) import IdInfo ( ArityInfo, exactArity ) import Class ( GenClass, GenClassOp, classSig, classOpLocalType ) @@ -44,6 +45,9 @@ import Pretty import Util ( assertPanic, pprTrace, assoc ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} @@ -86,14 +90,16 @@ addStandardIdInfo con_id = con_id `addIdUnfolding` unfolding `addIdArity` exactArity (length locals) where - unfolding = mkUnfolding True {- Always inline constructors -} con_rhs + unfolding = mkUnfolding IWantToBeINLINEd {- Always inline constructors -} con_rhs - (tyvars,theta,arg_tys,tycon) = dataConSig con_id - dict_tys = [mkDictTy clas ty | (clas,ty) <- theta] - n_dicts = length dict_tys - result_ty = applyTyCon tycon (mkTyVarTys tyvars) + (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) = dataConSig con_id - locals = mkTemplateLocals (dict_tys ++ arg_tys) + dict_tys = [mkDictTy clas ty | (clas,ty) <- theta] + con_dict_tys = [mkDictTy clas ty | (clas,ty) <- con_theta] + n_dicts = length dict_tys + result_ty = applyTyCon tycon (mkTyVarTys tyvars) + + locals = mkTemplateLocals (dict_tys ++ con_dict_tys ++ arg_tys) data_args = drop n_dicts locals (data_arg1:_) = data_args -- Used for newtype only strict_marks = dataConStrictMarks con_id @@ -144,7 +150,7 @@ addStandardIdInfo sel_id `addIdArity` exactArity 1 -- ToDo: consider adding further IdInfo where - unfolding = mkUnfolding False {- Don't inline every selector -} sel_rhs + unfolding = mkUnfolding NoPragmaInfo {- Don't inline every selector -} sel_rhs (tyvars, theta, tau) = splitSigmaTy (idType sel_id) field_lbl = recordSelectorFieldLabel sel_id @@ -169,7 +175,7 @@ addStandardIdInfo sel_id maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit] - full_msg = ppShow 80 (ppSep [ppStr "No match in record selector", ppr PprForUser sel_id]) + full_msg = show (sep [text "No match in record selector", ppr PprForUser sel_id]) msg_lit = NoRepStr (_PK_ full_msg) \end{code} @@ -189,7 +195,7 @@ addStandardIdInfo sel_id maybe_sc_sel_id = isSuperDictSelId_maybe sel_id Just (cls, the_sc) = maybe_sc_sel_id - unfolding = mkUnfolding True {- Always inline selectors -} rhs + unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id (tyvar, scs, ops) = classSig cls @@ -207,7 +213,7 @@ addStandardIdInfo sel_id maybe_meth_sel_id = isMethodSelId_maybe sel_id Just (cls, the_op) = maybe_meth_sel_id - unfolding = mkUnfolding True {- Always inline selectors -} rhs + unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id (tyvar, scs, ops) = classSig cls @@ -236,7 +242,7 @@ addStandardIdInfo prim_id maybe_prim_id = isPrimitiveId_maybe prim_id Just prim_op = maybe_prim_id - unfolding = mkUnfolding True {- Always inline PrimOps -} rhs + unfolding = mkUnfolding IWantToBeINLINEd {- Always inline PrimOps -} rhs (tyvars, tau) = splitForAllTy (idType prim_id) (arg_tys, _) = splitFunTy tau diff --git a/ghc/compiler/prelude/TysPrim.hi-boot b/ghc/compiler/prelude/TysPrim.hi-boot new file mode 100644 index 0000000..deb8bf0 --- /dev/null +++ b/ghc/compiler/prelude/TysPrim.hi-boot @@ -0,0 +1,5 @@ +_interface_ TysPrim 1 +_exports_ +TysPrim voidTy; +_declarations_ +1 voidTy _:_ Type.Type ;; diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 17ee58e..33bb877 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -16,8 +16,8 @@ IMP_Ubiq(){-uitous-} import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import Name ( mkWiredInTyConName ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn -import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) -import Type ( applyTyCon, mkTyVarTys, mkTyConTy ) +import TyCon --( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) +import Type --( applyTyCon, mkTyVarTys, mkTyConTy ) import TyVar ( GenTyVar(..), alphaTyVars ) import Usage ( usageOmega ) import PrelMods ( gHC__ ) diff --git a/ghc/compiler/prelude/TysWiredIn.hi-boot b/ghc/compiler/prelude/TysWiredIn.hi-boot new file mode 100644 index 0000000..b66a9e6 --- /dev/null +++ b/ghc/compiler/prelude/TysWiredIn.hi-boot @@ -0,0 +1,6 @@ +_interface_ TysWiredIn 1 +_exports_ +TysWiredIn tupleCon tupleTyCon; +_declarations_ +1 tupleCon _:_ PrelBase.Int -> Id.Id ;; +1 tupleTyCon _:_ PrelBase.Int -> TyCon.TyCon ;; diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 742510f..82ecbba 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -87,8 +87,10 @@ module TysWiredIn ( --import Kind IMP_Ubiq() -IMPORT_DELOOPER(TyLoop) ( mkDataCon, mkTupleCon, StrictnessMark(..) ) -IMPORT_DELOOPER(IdLoop) ( SpecEnv ) +IMPORT_DELOOPER(TyLoop) --( mkDataCon, mkTupleCon, StrictnessMark(..) ) +IMPORT_DELOOPER(IdLoop) ( SpecEnv, nullSpecEnv, + mkTupleCon, mkDataCon, + StrictnessMark(..) ) -- friends: import PrelMods @@ -96,9 +98,9 @@ import TysPrim -- others: import Kind ( mkBoxedTypeKind, mkArrowKind ) -import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr ) +import Name --( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, - NewOrData(..), TyCon + NewOrData(..), TyCon, SYN_IE(Arity) ) import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys, mkFunTy, mkFunTys, maybeAppTyCon, @@ -108,7 +110,7 @@ import Lex ( mkTupNameStr ) import Unique import Util ( assoc, panic ) -nullSpecEnv = error "TysWiredIn:nullSpecEnv = " +--nullSpecEnv = error "TysWiredIn:nullSpecEnv = " addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = " pc_gen_specs = error "TysWiredIn:pc_gen_specs " mkSpecInfo = error "TysWiredIn:SpecInfo" @@ -147,12 +149,12 @@ pcDataCon key mod str tyvars context arg_tys tycon specenv data_con = mkDataCon name [ NotMarkedStrict | a <- arg_tys ] [ {- no labelled fields -} ] - tyvars context arg_tys tycon + tyvars context [] [] arg_tys tycon name = mkWiredInIdName key mod str data_con pcGenerateDataSpecs :: Type -> SpecEnv pcGenerateDataSpecs ty - = pc_gen_specs False err err err ty + = pc_gen_specs --False err err err ty where err = panic "PrelUtils:GenerateDataSpecs" \end{code} @@ -222,14 +224,14 @@ intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intT wordTy = mkTyConTy wordTyCon wordTyCon = pcDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon] -wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv +wordDataCon = pcDataCon wordDataConKey fOREIGN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv \end{code} \begin{code} addrTy = mkTyConTy addrTyCon addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon] -addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv +addrDataCon = pcDataCon addrDataConKey fOREIGN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv \end{code} \begin{code} diff --git a/ghc/compiler/profiling/CostCentre.hi-boot b/ghc/compiler/profiling/CostCentre.hi-boot new file mode 100644 index 0000000..0f70e0d --- /dev/null +++ b/ghc/compiler/profiling/CostCentre.hi-boot @@ -0,0 +1,16 @@ +_interface_ CostCentre 1 +_exports_ +CostCentre CostCentre noCostCentre useCurrentCostCentre overheadCostCentre dontCareCostCentre subsumedCosts preludeCafsCostCentre mkAllCafsCC preludeDictsCostCentre mkAllDictsCC cafifyCC mkUserCC; +_declarations_ +1 data CostCentre; +1 noCostCentre _:_ CostCentre ;; +1 useCurrentCostCentre _:_ CostCentre ;; +1 overheadCostCentre _:_ CostCentre ;; +1 dontCareCostCentre _:_ CostCentre ;; +1 subsumedCosts _:_ CostCentre ;; +1 preludeCafsCostCentre _:_ CostCentre ;; +1 mkAllCafsCC _:_ FastString.FastString -> FastString.FastString -> CostCentre ;;;; +1 preludeDictsCostCentre _:_ PrelBase.Bool -> CostCentre ;; +1 mkAllDictsCC _:_ FastString.FastString -> FastString.FastString -> PrelBase.Bool -> CostCentre ;; +1 cafifyCC _:_ CostCentre -> CostCentre ;; +1 mkUserCC _:_ FastString.FastString -> FastString.FastString -> FastString.FastString -> CostCentre ;; diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 2f0b008..48f4f55 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -33,10 +33,9 @@ IMP_Ubiq(){-uitous-} import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) import Name ( OccName, getOccString, moduleString ) -import Pretty ( ppShow, prettyToUn ) -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), codeStyle, ifaceStyle ) import UniqSet -import Unpretty +import Pretty import Util pprIdInUnfolding = panic "Whoops" @@ -320,38 +319,40 @@ cmp_caf IsCafCC IsNotCafCC = GT_ \begin{code} showCostCentre :: PprStyle -> Bool -> CostCentre -> String -uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty -uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty +uppCostCentre :: PprStyle -> Bool -> CostCentre -> Doc +uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Doc +{- PprUnfolding is gone now showCostCentre PprUnfolding print_as_string cc = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding" ASSERT(not (noCostCentreAttached cc)) ASSERT(not (currentOrSubsumedCosts cc)) uppShow 80 (upp_cc_uf cc) +-} showCostCentre sty print_as_string cc - = uppShow 80 (uppCostCentre sty print_as_string cc) + = show (uppCostCentre sty print_as_string cc) uppCostCentre sty print_as_string NoCostCentre - | friendly_style sty = uppNil - | print_as_string = uppStr "\"NO_CC\"" - | otherwise = uppPStr SLIT("NO_CC") + | friendly_style sty = empty + | print_as_string = text "\"NO_CC\"" + | otherwise = ptext SLIT("NO_CC") uppCostCentre sty print_as_string SubsumedCosts - | print_as_string = uppStr "\"SUBSUMED\"" - | otherwise = uppPStr SLIT("CC_SUBSUMED") + | print_as_string = text "\"SUBSUMED\"" + | otherwise = ptext SLIT("CC_SUBSUMED") uppCostCentre sty print_as_string CurrentCC - | print_as_string = uppStr "\"CURRENT_CC\"" - | otherwise = uppPStr SLIT("CCC") + | print_as_string = text "\"CURRENT_CC\"" + | otherwise = ptext SLIT("CCC") uppCostCentre sty print_as_string OverheadCC - | print_as_string = uppStr "\"OVERHEAD\"" - | otherwise = uppPStr SLIT("CC_OVERHEAD") + | print_as_string = text "\"OVERHEAD\"" + | otherwise = ptext SLIT("CC_OVERHEAD") uppCostCentre sty print_as_string cc = let - prefix_CC = uppPStr SLIT("CC_") + prefix_CC = ptext SLIT("CC_") basic_thing = do_cc cc @@ -359,13 +360,12 @@ uppCostCentre sty print_as_string cc = if friendly_sty then basic_thing else stringToC basic_thing in if print_as_string then - uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"'] + hcat [char '"', text basic_thing_string, char '"'] else if friendly_sty then - uppStr basic_thing + text basic_thing else - uppBesides [prefix_CC, - prettyToUn (identToC (_PK_ basic_thing))] + hcat [prefix_CC, identToC (_PK_ basic_thing)] where friendly_sty = friendly_style sty @@ -413,11 +413,7 @@ uppCostCentre sty print_as_string cc do_dupd _ str = str friendly_style sty -- i.e., probably for human consumption - = case sty of - PprForUser -> True - PprDebug -> True - PprShowAll -> True - _ -> False + = not (codeStyle sty || ifaceStyle sty) \end{code} Printing unfoldings is sufficiently weird that we do it separately. @@ -428,37 +424,37 @@ Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info; even if we won't ultimately do a \tr{SET_CCC} from it. \begin{code} upp_cc_uf (PreludeDictsCC d) - = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] + = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] upp_cc_uf (AllDictsCC m g d) - = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), - uppChar '"',uppPStr m,uppChar '"', - uppChar '"',uppPStr g,uppChar '"', + = hsep [ptext SLIT("_ALL_DICTS_CC_"), + char '"',ptext m,char '"', + char '"',ptext g,char '"', upp_dupd d] upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) = ASSERT(sccAbleCostCentre cc) - uppCat [pp_kind cc_kind, - uppChar '"', uppPStr m, uppChar '"', - uppChar '"', uppPStr g, uppChar '"', + hsep [pp_kind cc_kind, + char '"', ptext m, char '"', + char '"', ptext g, char '"', upp_dupd is_dupd, pp_caf is_caf] where - pp_kind (UserCC name) = uppBesides [uppPStr SLIT("_USER_CC_ "), uppChar '"', uppPStr name, uppChar '"'] - pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id) - pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id) + pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"'] + pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id) + pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id) - show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id) + show_id id = pprIdInUnfolding no_in_scopes id where no_in_scopes = emptyUniqSet - pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_") - pp_caf IsNotCafCC = uppPStr SLIT("_N_") + pp_caf IsCafCC = ptext SLIT("_CAF_CC_") + pp_caf IsNotCafCC = ptext SLIT("_N_") #ifdef DEBUG upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) #endif -upp_dupd AnOriginalCC = uppPStr SLIT("_N_") -upp_dupd ADupdCC = uppPStr SLIT("_D_") +upp_dupd AnOriginalCC = ptext SLIT("_N_") +upp_dupd ADupdCC = ptext SLIT("_D_") \end{code} \begin{code} @@ -469,22 +465,21 @@ uppCostCentreDecl sty is_local cc | otherwise #endif = if is_local then - uppBesides [ - uppPStr SLIT("CC_DECLARE"),uppChar '(', - upp_ident, uppComma, - uppCostCentre sty True {-as String!-} cc, uppComma, - pp_str mod_name, uppComma, - pp_str grp_name, uppComma, - uppStr is_subsumed, uppComma, - if externally_visible then uppNil else uppPStr SLIT("static"), - uppStr ");"] + hcat [ + ptext SLIT("CC_DECLARE"),char '(', + upp_ident, comma, + uppCostCentre sty True {-as String!-} cc, comma, + pp_str mod_name, comma, + pp_str grp_name, comma, + text is_subsumed, comma, + if externally_visible then empty else ptext SLIT("static"), + text ");"] else - uppBesides [ uppPStr SLIT("CC_EXTERN"),uppChar '(', upp_ident, uppStr ");" ] + hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ] where upp_ident = uppCostCentre sty False{-as identifier!-} cc - pp_str s = uppBesides [uppChar '"',uppPStr s, uppChar '"' ] - pp_char c = uppBesides [uppChar '\'', uppPStr c, uppChar '\''] + pp_str s = doubleQuotes (ptext s) (mod_name, grp_name, is_subsumed, externally_visible) = case cc of diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 24e0fb3..2e987d6 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -35,12 +35,13 @@ import CmdLineOpts ( opt_AutoSccsOnIndividualCafs, opt_CompilingGhcInternals ) import CostCentre -- lots of things -import Id ( idType, mkSysLocal, emptyIdSet ) +import Id ( idType, mkSysLocal, emptyIdSet, SYN_IE(Id) ) import Maybes ( maybeToBool ) import PprStyle -- ToDo: rm import SrcLoc ( noSrcLoc ) import Type ( splitSigmaTy, getFunTy_maybe ) -import UniqSupply ( getUnique, splitUniqSupply ) +import UniqSupply ( getUnique, splitUniqSupply, UniqSupply ) +import Unique ( Unique ) import Util ( removeDups, assertPanic ) infixr 9 `thenMM`, `thenMM_` diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index edc6f05..23cc723 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -19,7 +19,7 @@ module Lex ( ) where -IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) +IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper,isLower, isSpace, ord)) IMPORT_DELOOPER(Ubiq) IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here @@ -27,9 +27,12 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( UniqFM, listToUFM, lookupUFM) --import FiniteMap ( FiniteMap, listToFM, lookupFM ) +#if __GLASGOW_HASKELL__ >= 202 +import Maybes ( MaybeErr(..) ) +#else import Maybes ( Maybe(..), MaybeErr(..) ) +#endif import Pretty -import CharSeq ( CSeq ) @@ -41,8 +44,11 @@ import Util ( nOfThem, panic ) import FastString import StringBuffer +#if __GLASGOW_HASKELL__ <= 201 import PreludeGlaST - +#else +import GlaExts +#endif \end{code} %************************************************************************ @@ -302,8 +308,7 @@ lexIface buf = lex_demand (stepOnUntil (not . isSpace) (stepOnBy# buf 3#)) -- past _S_ 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of - Just buf' -> lex_scc (stepOnUntil (not . isSpace) - (stepOverLexeme buf')) + Just buf' -> lex_scc (stepOnUntil (not . isSpace) (stepOverLexeme buf')) Nothing -> lex_keyword (stepOnBy# buf 1#) -- drop the '_' and assume -- it is a keyword. _ -> lex_keyword (stepOn buf) @@ -374,7 +379,7 @@ lex_scc buf = Just buf' -> case untilChar# (stepOverLexeme buf') '\"'# of buf'' -> ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_): - lexIface (stepOverLexeme buf'') + lexIface (stepOn (stepOverLexeme buf'')) Nothing -> case prefixMatch (stepOn buf) "DICTs_in_...\"" of Just buf' -> ITscc (preludeDictsCostCentre True) : lexIface (stepOverLexeme buf') @@ -383,17 +388,17 @@ lex_scc buf = Just buf' -> case untilChar# (stepOverLexeme buf') '\"'# of buf'' -> ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True): - lexIface (stepOverLexeme buf'') + lexIface (stepOn (stepOverLexeme buf'')) Nothing -> case prefixMatch (stepOn buf) "CAF:" of Just buf' -> case untilChar# (stepOverLexeme buf') '\"'# of buf'' -> ITscc (cafifyCC (mkUserCC (lexemeToFastString buf'') _NIL_ _NIL_)): - lexIface (stepOverLexeme buf'') + lexIface (stepOn (stepOverLexeme buf'')) Nothing -> case untilChar# (stepOn buf) '\"'# of buf' -> ITscc (mkUserCC (lexemeToFastString buf') _NIL_ _NIL_): - lexIface (stepOverLexeme buf') + lexIface (stepOn (stepOverLexeme buf')) c -> ITunknown [C# c] : lexIface (stepOn buf) @@ -526,12 +531,12 @@ is_id_char (C# c#) = is_sym c#= case c# of { - ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True; - '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True; - '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True; - '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True; - '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True; - '-'# -> True; '~'# -> True; '@'# -> True; _ -> False } + ':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True; + '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True; + '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True; + '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True; + '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True; + '-'# -> True; '~'# -> True; '@'# -> True; _ -> False } --isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic @@ -706,6 +711,7 @@ ifaceKeywordsFM = listToUFM $ map (\ (x,y) -> (_PK_ x,y)) [("/\\_", ITbiglam) ,("@_", ITatsign) + ,("letrec_", ITletrec) ,("interface_", ITinterface) ,("usages_", ITusages) ,("versions_", ITversions) @@ -749,7 +755,6 @@ haskellKeywordsFM = listToUFM $ ,("of", ITof) ,("in", ITin) ,("let", ITlet) - ,("letrec", ITletrec) ,("deriving", ITderiving) ,("->", ITrarrow) @@ -774,9 +779,20 @@ doDiscard inStr buf = else doDiscard inStr (incLexeme buf) '"'# -> + let + odd_slashes buf flg i# = + case lookAhead# buf i# of + '\\'# -> odd_slashes buf (not flg) (i# -# 1#) + _ -> flg + in case lookAhead# buf (negateInt# 1#) of --backwards, actually - '\\'# -> -- false alarm, escaped. - doDiscard inStr (incLexeme buf) + '\\'# -> -- escaping something.. + if odd_slashes buf True (negateInt# 2#) then + -- odd number of slashes, " is escaped. + doDiscard inStr (incLexeme buf) + else + -- even number of slashes, \ is escaped. + doDiscard (not inStr) (incLexeme buf) _ -> case inStr of -- forced to avoid build-up True -> doDiscard False (incLexeme buf) False -> doDiscard True (incLexeme buf) @@ -822,5 +838,5 @@ happyError ln toks = Failed (ifaceParseErr ln toks) ----------------------------------------------------------------- ifaceParseErr ln toks sty - = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppPStr SLIT("toks="), ppStr (show (take 10 toks))] + = hsep [ptext SLIT("Interface-file parse error: line"), int ln, ptext SLIT("toks="), text (show (take 10 toks))] \end{code} diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index fdf9b11..d91c711 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -28,6 +28,7 @@ IMPORT_1_3(Char(isDigit)) import HsSyn import RdrHsSyn import Util ( panic ) +import SrcLoc ( SrcLoc ) #ifdef REALLY_HASKELL_1_3 ord = fromEnum :: Char -> Int @@ -80,7 +81,7 @@ data RdrMatch | RdrMatch_Guards SrcLine SrcFun RdrNamePat - [(RdrNameHsExpr, RdrNameHsExpr)] + [([RdrNameStmt], RdrNameHsExpr)] -- (guard, expr) RdrBinding \end{code} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index 1892af8..a984397 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -67,9 +67,7 @@ analyser. cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds cvBinds sf sig_cvtr binding = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) -> - if (null sigs) - then SingleBind (RecBind mbs) - else BindWith (RecBind mbs) sigs + MonoBind mbs sigs recursive } \end{code} @@ -182,7 +180,7 @@ cvMatch sf is_case rdr_match RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)]) RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps) -cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS +cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl) \end{code} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index d7bbd7f..84465f1 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -12,7 +12,6 @@ they are used somewhat later on in the compiler...) module RdrHsSyn ( SYN_IE(RdrNameArithSeqInfo), SYN_IE(RdrNameBangType), - SYN_IE(RdrNameBind), SYN_IE(RdrNameClassDecl), SYN_IE(RdrNameClassOpSig), SYN_IE(RdrNameConDecl), @@ -61,17 +60,21 @@ IMP_Ubiq() import HsSyn import Lex import PrelMods ( pRELUDE ) -import Name ( ExportFlag(..), Module(..), pprModule, - OccName(..), pprOccName, prefixOccName ) +import Name {- ( ExportFlag(..), Module(..), pprModule, + OccName(..), pprOccName, prefixOccName ) -} import Pretty import PprStyle ( PprStyle(..) ) -import Util ( cmpPString, panic, thenCmp ) +import Util --( cmpPString, panic, thenCmp ) +import Outputable +#if __GLASGOW_HASKELL__ >= 202 +import CoreSyn ( GenCoreExpr ) +import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas ) +#endif \end{code} \begin{code} type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat type RdrNameBangType = BangType RdrName -type RdrNameBind = Bind Fake Fake RdrName RdrNamePat type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName @@ -190,7 +193,7 @@ ieOcc :: RdrNameIE -> OccName ieOcc ie = rdrNameOcc (ieName ie) instance Text RdrName where -- debugging - showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn)) + showsPrec _ rn = showString (show (ppr PprDebug rn)) instance Eq RdrName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -206,13 +209,13 @@ instance Ord3 RdrName where cmp = cmpRdr instance Outputable RdrName where - ppr sty (Unqual n) = pprOccName sty n - ppr sty (Qual m n) = ppBesides [pprModule sty m, ppChar '.', pprOccName sty n] + ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n + ppr sty (Qual m n) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n] instance NamedThing RdrName where -- Just so that pretty-printing of expressions works getOccName = rdrNameOcc getName = panic "no getName for RdrNames" -showRdr sty rdr = ppShow 100 (ppr sty rdr) +showRdr sty rdr = render (ppr sty rdr) \end{code} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index d72394f..2fb3028 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -10,25 +10,36 @@ module ReadPrefix ( rdModule ) where IMP_Ubiq() IMPORT_1_3(IO(hPutStr, stderr)) -IMPORT_1_3(GHCio(stThen)) +#if __GLASGOW_HASKELL__ == 201 +import GHCio(stThen) +#elif __GLASGOW_HASKELL__ >= 202 +import GlaExts +import IOBase +import PrelRead +#endif import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. import HsSyn import HsTypes ( HsTyVar(..) ) import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas ) -import RdrHsSyn +import RdrHsSyn import PrefixToHs import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( RdrName(..), OccName(..) ) +import Name ( OccName(..), SYN_IE(Module) ) import Lex ( isLexConId ) import PprStyle ( PprStyle(..) ) import PrelMods import Pretty import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc ) import Util ( nOfThem, pprError, panic ) + +#if __GLASGOW_HASKELL__ >= 202 +import Outputable ( Outputable(..) ) +#endif + \end{code} %************************************************************************ @@ -91,19 +102,19 @@ cvFlag 1 = True %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 # define PACK_STR packCString -# define CCALL_THEN `stThen` +#elif __GLASGOW_HASKELL__ >= 202 +# define PACK_STR mkFastCharString #else # define PACK_STR mkFastCharString -# define CCALL_THEN `thenPrimIO` #endif rdModule :: IO (Module, -- this module's name RdrNameHsModule) -- the main goods rdModule - = _ccall_ hspmain CCALL_THEN \ pt -> -- call the Yacc parser! + = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser! let srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM) in @@ -248,34 +259,9 @@ wlkExpr expr U_comprh cexp cquals -> -- list comprehension wlkExpr cexp `thenUgn` \ expr -> - wlkList rd_qual cquals `thenUgn` \ quals -> + wlkQuals cquals `thenUgn` \ quals -> getSrcLocUgn `thenUgn` \ loc -> returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc) - where - rd_qual pt - = rdU_tree pt `thenUgn` \ qual -> - wlk_qual qual - - wlk_qual qual - = case qual of - U_guard exp -> - wlkExpr exp `thenUgn` \ expr -> - getSrcLocUgn `thenUgn` \ loc -> - returnUgn (GuardStmt expr loc) - - U_qual qpat qexp -> - wlkPat qpat `thenUgn` \ pat -> - wlkExpr qexp `thenUgn` \ expr -> - getSrcLocUgn `thenUgn` \ loc -> - returnUgn (BindStmt pat expr loc) - - U_seqlet seqlet -> - wlkBinding seqlet `thenUgn` \ bs -> - getSrcFileUgn `thenUgn` \ sf -> - let - binds = cvBinds sf cvValSig bs - in - returnUgn (LetStmt binds) U_eenum efrom estep eto -> -- arithmetic sequence wlkExpr efrom `thenUgn` \ e1 -> @@ -363,6 +349,34 @@ rdRbind pt Nothing -> (rvar, HsVar rvar, True{-pun-}) Just re -> (rvar, re, False) ) + +wlkQuals cquals + = wlkList rd_qual cquals + where + rd_qual pt + = rdU_tree pt `thenUgn` \ qual -> + wlk_qual qual + + wlk_qual qual + = case qual of + U_guard exp -> + wlkExpr exp `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (GuardStmt expr loc) + + U_qual qpat qexp -> + wlkPat qpat `thenUgn` \ pat -> + wlkExpr qexp `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (BindStmt pat expr loc) + + U_seqlet seqlet -> + wlkBinding seqlet `thenUgn` \ bs -> + getSrcFileUgn `thenUgn` \ sf -> + let + binds = cvBinds sf cvValSig bs + in + returnUgn (LetStmt binds) \end{code} Patterns: just bear in mind that lists of patterns are represented as @@ -418,12 +432,15 @@ wlkPat pat _ -> getSrcLocUgn `thenUgn` \ loc -> let err = addErrLoc loc "Illegal pattern `application'" - (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats))) - msg = ppShow 100 (err PprForUser) + (\sty -> hsep (map (ppr sty) (lpat:lpats))) + msg = show (err PprForUser) in -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> +#elif __GLASGOW_HASKELL__ >= 202 + ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> + ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> #else ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ -> ioToUgnM (ghcExit 1) `thenUgn` \ _ -> @@ -496,8 +513,10 @@ wlkLiteral ulit where as_char s = _HEAD_ s as_integer s = readInteger (_UNPK_ s) -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std +#elif __GLASGOW_HASKELL__ >= 202 + as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a } -- ToDo, use non-std readRational__ #else as_rational s = _readRational (_UNPK_ s) -- non-std #endif @@ -532,16 +551,16 @@ wlkBinding binding wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> wlkList rdConDecl tcons `thenUgn` \ cons -> wlkDerivings tderivs `thenUgn` \ derivings -> - returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc)) + returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) -- "newtype" declaration U_ntbind ntctxt nttype ntcon ntderivs srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext ntctxt `thenUgn` \ ctxt -> wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> - wlkList rdConDecl ntcon `thenUgn` \ [con] -> + wlkList rdConDecl ntcon `thenUgn` \ cons -> wlkDerivings ntderivs `thenUgn` \ derivings -> - returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc)) + returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) -- "type" declaration U_nbind nbindid nbindas srcline -> @@ -697,6 +716,12 @@ wlkHsType ttype wlkMonoType ttype = case ttype of + -- Glasgow extension: nested polymorhism + U_context tcontextl tcontextt -> -- context + wlkContext tcontextl `thenUgn` \ ctxt -> + wlkMonoType tcontextt `thenUgn` \ ty -> + returnUgn (HsPreForAllTy ctxt ty) + U_namedtvar tv -> -- type variable wlkTvId tv `thenUgn` \ tyvar -> returnUgn (MonoTyVar tyvar) @@ -765,30 +790,35 @@ rdConDecl pt wlkConDecl :: U_constr -> UgnM RdrNameConDecl +wlkConDecl (U_constrcxt ccxt ccdecl) + = wlkContext ccxt `thenUgn` \ theta -> + wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) -> + returnUgn (ConDecl con theta details loc) + wlkConDecl (U_constrpre ccon ctys srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkDataId ccon `thenUgn` \ con -> wlkList rdBangType ctys `thenUgn` \ tys -> - returnUgn (ConDecl con tys src_loc) + returnUgn (ConDecl con [] (VanillaCon tys) src_loc) wlkConDecl (U_constrinf cty1 cop cty2 srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkBangType cty1 `thenUgn` \ ty1 -> wlkDataId cop `thenUgn` \ op -> wlkBangType cty2 `thenUgn` \ ty2 -> - returnUgn (ConOpDecl ty1 op ty2 src_loc) + returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc) wlkConDecl (U_constrnew ccon cty srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkDataId ccon `thenUgn` \ con -> wlkMonoType cty `thenUgn` \ ty -> - returnUgn (NewConDecl con ty src_loc) + returnUgn (ConDecl con [] (NewCon ty) src_loc) wlkConDecl (U_constrrec ccon cfields srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkDataId ccon `thenUgn` \ con -> wlkList rd_field cfields `thenUgn` \ fields_lists -> - returnUgn (RecConDecl con fields_lists src_loc) + returnUgn (ConDecl con [] (RecCon fields_lists) src_loc) where rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName) rd_field pt @@ -836,7 +866,7 @@ rdMatch pt where rd_gd_expr pt = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) -> - wlkExpr g `thenUgn` \ guard -> + wlkQuals g `thenUgn` \ guard -> wlkExpr e `thenUgn` \ expr -> returnUgn (guard, expr) \end{code} diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 5107c5b..2e58b1f 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -14,7 +14,7 @@ import HsCore import Literal import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, - ArgUsageInfo, FBTypeInfo + ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo ) import Kind ( Kind, mkArrowKind, mkTypeKind ) import Lex @@ -24,7 +24,7 @@ import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), isTCOcc, Provenance ) +import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) import ParseType ( parseType ) @@ -232,9 +232,9 @@ topdecl :: { RdrNameHsDecl } topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) } | DATA decl_context tc_name tv_bndrs constrs deriving SEMI - { TyD (TyData $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } - | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI - { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) } + { TyD (TyData DataType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } + | NEWTYPE decl_context tc_name tv_bndrs newtype_constr deriving SEMI + { TyD (TyData NewType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } | CLASS decl_context tc_name tv_bndr csigs SEMI { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } | var_name TYPE_PART id_info @@ -266,7 +266,7 @@ csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc ---------------------------------------------------------------- } -constrs :: { [RdrNameConDecl] } +constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} } : { [] } | EQUAL constrs1 { $2 } @@ -275,15 +275,16 @@ constrs1 : constr { [$1] } | constr VBAR constrs1 { $1 : $3 } constr :: { RdrNameConDecl } -constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc } - | data_name OCURLY fields1 CCURLY { RecConDecl $1 $3 mkIfaceSrcLoc } +constr : data_name batypes { ConDecl $1 [] (VanillaCon $2) mkIfaceSrcLoc } + | data_name OCURLY fields1 CCURLY { ConDecl $1 [] (RecCon $3) mkIfaceSrcLoc } -constr1 :: { RdrNameConDecl {- For a newtype -} } -constr1 : data_name atype { NewConDecl $1 $2 mkIfaceSrcLoc } +newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} } +newtype_constr : { [] } + | EQUAL data_name atype { [ConDecl $2 [] (NewCon $3) mkIfaceSrcLoc] } deriving :: { Maybe [RdrName] } : { Nothing } - | DERIVING OPAREN qtc_names1 CPAREN { Just $3 } + | DERIVING OPAREN tc_names1 CPAREN { Just $3 } batypes :: { [RdrNameBangType] } batypes : { [] } @@ -315,15 +316,12 @@ context_list1 : class { [$1] } | class COMMA context_list1 { $1 : $3 } class :: { (RdrName, RdrNameHsType) } -class : qtc_name atype { ($1, $2) } +class : tc_name atype { ($1, $2) } type :: { RdrNameHsType } type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | tautype { $1 } - -tautype :: { RdrNameHsType } -tautype : btype { $1 } - | btype RARROW tautype { MonoFunTy $1 $3 } + | btype RARROW type { MonoFunTy $1 $3 } + | btype { $1 } types2 :: { [RdrNameHsType] {- Two or more -} } types2 : type COMMA type { [$1,$3] } @@ -334,11 +332,11 @@ btype : atype { $1 } | btype atype { MonoTyApp $1 $2 } atype :: { RdrNameHsType } -atype : qtc_name { MonoTyVar $1 } +atype : tc_name { MonoTyVar $1 } | tv_name { MonoTyVar $1 } | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } | OPAREN type CPAREN { $2 } atypes :: { [RdrNameHsType] {- Zero or more -} } @@ -399,15 +397,13 @@ data_name : CONID { Unqual (VarOcc $1) } | CONSYM { Unqual (VarOcc $1) } -qtc_name :: { RdrName } -qtc_name : QCONID { tcQual $1 } - -qtc_names1 :: { [RdrName] } - : qtc_name { [$1] } - | qtc_name COMMA qtc_names1 { $1 : $3 } +tc_names1 :: { [RdrName] } + : tc_name { [$1] } + | tc_name COMMA tc_names1 { $1 : $3 } tc_name :: { RdrName } tc_name : tc_occ { Unqual $1 } + | QCONID { tcQual $1 } tv_name :: { RdrName } tv_name : VARID { Unqual (TvOcc $1) } diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y index d39c56b..949707d 100644 --- a/ghc/compiler/rename/ParseType.y +++ b/ghc/compiler/rename/ParseType.y @@ -25,19 +25,19 @@ import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) import Name ( OccName(..), isTCOcc, Provenance ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) -import Pretty ( ppShow ) +import Pretty ( Doc ) import PprStyle -- PprDebug for panic import Maybes ( MaybeErr(..) ) ------------------------------------------------------------------ -parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep) +parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Doc) parseType ls = let res = case parseT ls of v@(Succeeded _) -> v - Failed err -> panic (ppShow 80 (err PprDebug)) + Failed err -> panic (show (err PprDebug)) in res @@ -71,7 +71,8 @@ parseType ls = type :: { RdrNameHsType } type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | tautype { $1 } + | btype RARROW type { MonoFunTy $1 $3 } + | btype { $1 } forall : OBRACK tv_bndrs CBRACK { $2 } @@ -84,13 +85,9 @@ context_list1 : class { [$1] } | class COMMA context_list1 { $1 : $3 } class :: { (RdrName, RdrNameHsType) } -class : qtc_name atype { ($1, $2) } +class : tc_name atype { ($1, $2) } -tautype :: { RdrNameHsType } -tautype : btype { $1 } - | btype RARROW tautype { MonoFunTy $1 $3 } - types2 :: { [RdrNameHsType] {- Two or more -} } types2 : type COMMA type { [$1,$3] } | type COMMA types2 { $1 : $3 } @@ -100,11 +97,11 @@ btype : atype { $1 } | btype atype { MonoTyApp $1 $2 } atype :: { RdrNameHsType } -atype : qtc_name { MonoTyVar $1 } +atype : tc_name { MonoTyVar $1 } | tv_name { MonoTyVar $1 } | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } | OPAREN type CPAREN { $2 } atypes :: { [RdrNameHsType] {- Zero or more -} } @@ -135,6 +132,10 @@ tv_name : VARID { Unqual (TvOcc $1) } tv_names :: { [RdrName] } : { [] } | tv_name tv_names { $1 : $2 } -qtc_name :: { RdrName } -qtc_name : QCONID { tcQual $1 } + +tc_name :: { RdrName } +tc_name : QCONID { tcQual $1 } + | CONID { Unqual (TCOcc $1) } + | CONSYM { Unqual (TCOcc $1) } + | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) } diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y index 1336fb9..72a7c30 100644 --- a/ghc/compiler/rename/ParseUnfolding.y +++ b/ghc/compiler/rename/ParseUnfolding.y @@ -13,7 +13,7 @@ import Literal import PrimRep ( decodePrimRep ) import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo, - ArgUsageInfo, FBTypeInfo + ArgUsageInfo, FBTypeInfo, ArityInfo, StrictnessInfo ) import Kind ( Kind, mkArrowKind, mkTypeKind ) import Lex @@ -23,10 +23,10 @@ import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..), ) import Bag ( emptyBag, unitBag, snocBag ) import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) -import Name ( OccName(..), isTCOcc, Provenance ) +import Name ( OccName(..), isTCOcc, Provenance, SYN_IE(Module) ) import SrcLoc ( mkIfaceSrcLoc ) import Util ( panic{-, pprPanic ToDo:rm-} ) -import Pretty ( ppShow ) +import Pretty ( Doc ) import PprStyle -- PprDebug for panic import Maybes ( MaybeErr(..) ) @@ -38,7 +38,7 @@ parseUnfolding ls = case parseUnfold ls of v@(Succeeded _) -> v -- ill-formed unfolding, crash and burn. - Failed err -> panic (ppShow 80 (err PprDebug)) + Failed err -> panic (show (err PprDebug)) in res } @@ -135,10 +135,10 @@ strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) } core_expr :: { UfExpr RdrName } core_expr : any_var_name { UfVar $1 } - | qdata_name { UfVar $1 } + | data_name { UfVar $1 } | core_lit { UfLit $1 } | OPAREN core_expr CPAREN { $2 } - | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 } + | data_name OCURLY data_args CCURLY { UfCon $1 $3 } | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) } | core_expr core_arg { UfApp $1 $2 } @@ -165,15 +165,15 @@ core_expr : any_var_name { UfVar $1 } UfPrim (UfCCallOp $2 is_casm may_gc $5 $4) $7 } - | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 } + | SCC core_expr { UfSCC $1 $2 } rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } : { [] } | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 } coerce :: { UfCoercion RdrName } -coerce : COERCE_IN qdata_name { UfIn $2 } - | COERCE_OUT qdata_name { UfOut $2 } +coerce : COERCE_IN data_name { UfIn $2 } + | COERCE_OUT data_name { UfOut $2 } prim_alts :: { [(Literal,UfExpr RdrName)] } : { [] } @@ -181,7 +181,7 @@ prim_alts :: { [(Literal,UfExpr RdrName)] } alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] } : { [] } - | qdata_name var_names RARROW + | data_name var_names RARROW core_expr SEMI alg_alts { ($1,$2,$4) : $6 } core_default :: { UfDefault RdrName } @@ -189,9 +189,8 @@ core_default :: { UfDefault RdrName } | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 } core_arg :: { UfArg RdrName } - : var_name { UfVarArg $1 } - | qvar_name { UfVarArg $1 } - | qdata_name { UfVarArg $1 } + : any_var_name { UfVarArg $1 } + | data_name { UfVarArg $1 } | core_lit { UfLitArg $1 } core_args :: { [UfArg RdrName] } @@ -254,9 +253,11 @@ var_occ : VARID { VarOcc $1 } | VARSYM { VarOcc $1 } | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} } -qdata_name :: { RdrName } -qdata_name : QCONID { varQual $1 } +data_name :: { RdrName } +data_name : QCONID { varQual $1 } | QCONSYM { varQual $1 } + | CONID { Unqual (VarOcc $1) } + | CONSYM { Unqual (VarOcc $1) } qvar_name :: { RdrName } : QVARID { varQual $1 } @@ -286,15 +287,12 @@ context_list1 : class { [$1] } | class COMMA context_list1 { $1 : $3 } class :: { (RdrName, RdrNameHsType) } -class : qtc_name atype { ($1, $2) } +class : tc_name atype { ($1, $2) } type :: { RdrNameHsType } type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 } - | tautype { $1 } - -tautype :: { RdrNameHsType } -tautype : btype { $1 } - | btype RARROW tautype { MonoFunTy $1 $3 } + | btype RARROW type { MonoFunTy $1 $3 } + | btype { $1 } types2 :: { [RdrNameHsType] {- Two or more -} } types2 : type COMMA type { [$1,$3] } @@ -305,11 +303,11 @@ btype : atype { $1 } | btype atype { MonoTyApp $1 $2 } atype :: { RdrNameHsType } -atype : qtc_name { MonoTyVar $1 } +atype : tc_name { MonoTyVar $1 } | tv_name { MonoTyVar $1 } | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 } | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 } - | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 } + | OCURLY tc_name atype CCURLY { MonoDictTy $2 $3 } | OPAREN type CPAREN { $2 } atypes :: { [RdrNameHsType] {- Zero or more -} } @@ -340,5 +338,9 @@ tv_name : VARID { Unqual (TvOcc $1) } tv_names :: { [RdrName] } : { [] } | tv_name tv_names { $1 : $2 } -qtc_name :: { RdrName } -qtc_name : QCONID { tcQual $1 } + +tc_name :: { RdrName } +tc_name : QCONID { tcQual $1 } + | CONID { Unqual (TCOcc $1) } + | CONSYM { Unqual (TCOcc $1) } + | OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 81059c2..08ea032 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,28 +8,37 @@ module Rename ( renameModule ) where +#if __GLASGOW_HASKELL__ <= 201 import PreludeGlaST ( thenPrimIO ) +#else +import GlaExts +import IO +#endif IMP_Ubiq() IMPORT_1_3(List(partition)) import HsSyn -import RdrHsSyn ( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) +import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) ) import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames ) -import CmdLineOpts ( opt_HiMap ) +import CmdLineOpts ( opt_HiMap, opt_WarnNameShadowing, opt_D_show_rn_trace, + opt_D_dump_rn, opt_D_show_passes + ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnDecl ) import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules, - mkSearchPath + getDeferredDataDecls, + mkSearchPath, getSlurpedNames, getRnStats ) import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn, lookupImplicitOccRn ) import Id ( GenId {- instance NamedThing -} ) import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined, - NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList, - isWiredInName, modAndOcc + NameSet(..), elemNameSet, mkNameSet, unionNameSets, + nameSetToList, minusNameSet, NamedThing(..), + modAndOcc, pprModule, pprOccName, nameOccName ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon ) import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME ) @@ -39,7 +48,10 @@ import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap ) import Pretty import PprStyle ( PprStyle(..) ) -import Util ( panic, assertPanic, pprTrace ) +import Util ( cmpPString, equivClasses, panic, assertPanic, pprTrace ) +#if __GLASGOW_HASKELL__ >= 202 +import UniqSupply +#endif \end{code} @@ -69,10 +81,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ case global_name_info of { Nothing -> -- Everything is up to date; no need to recompile further + rnStats [] `thenRn_` returnRn Nothing ; -- Otherwise, just carry on - Just (export_env, rn_env, local_avails) -> + Just (export_env, rn_env, explicit_names) -> -- RENAME THE SOURCE initRnMS rn_env mod_name SourceMode ( @@ -88,6 +101,8 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ getImportVersions mod_name exports `thenRn` \ import_versions -> getNameSupplyRn `thenRn` \ name_supply -> + -- REPORT UNUSED NAMES + reportUnusedNames explicit_names `thenRn_` -- GENERATE THE SPECIAL-INSTANCE MODULE LIST -- The "special instance" modules are those modules that contain instance @@ -103,7 +118,6 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ in - -- RETURN THE RENAMED MODULE let import_mods = [mod | ImportDecl mod _ _ _ _ <- imports] @@ -113,6 +127,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_ rn_all_decls loc in + rnStats rn_all_decls `thenRn_` returnRn (Just (renamed_module, (import_versions, export_env, special_inst_mods), name_supply, @@ -155,31 +170,35 @@ closeDecls decls case maybe_unresolved of -- No more unresolved names - Nothing -> -- Slurp instance declarations + Nothing -> -- Instance decls still pending? getImportedInstDecls `thenRn` \ inst_decls -> - traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")]) + traceRn (sep [ptext SLIT("Slurped"), int (length inst_decls), ptext SLIT("instance decls")]) `thenRn_` - - -- None? then at last we are done - if null inst_decls then - returnRn decls - else - mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> - - -- We *must* loop again here. Why? Two reasons: - -- (a) an instance decl will give rise to an unresolved dfun, whose - -- decl we must slurp to get its version number; that's the version - -- number for the whole instance decl. - -- (b) an instance decl might give rise to a new unresolved class, - -- whose decl we must slurp, which might let in some new instance decls, - -- and so on. Example: instance Foo a => Baz [a] where ... - - closeDecls (new_inst_decls ++ decls) + if not (null inst_decls) then + mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls -> + + -- We *must* loop again here. Why? Two reasons: + -- (a) an instance decl will give rise to an unresolved dfun, whose + -- decl we must slurp to get its version number; that's the version + -- number for the whole instance decl. (And its unfolding might mention new + -- unresolved names.) + -- (b) an instance decl might give rise to a new unresolved class, + -- whose decl we must slurp, which might let in some new instance decls, + -- and so on. Example: instance Foo a => Baz [a] where ... + + closeDecls (new_inst_decls ++ decls) + else + + -- No more instance decls, so all we have left is + -- to deal with the deferred data type decls. + getDeferredDataDecls `thenRn` \ data_decls -> + mapRn rn_data_decl data_decls `thenRn` \ rn_data_decls -> + returnRn (rn_data_decls ++ decls) -- An unresolved name Just (name,necessity) -> -- Slurp its declaration, if any --- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_` +-- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_` importDecl name necessity `thenRn` \ maybe_decl -> case maybe_decl of @@ -189,13 +208,61 @@ closeDecls decls -- Found a declaration... rename it Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl -> closeDecls (new_decl : decls) - where - (mod_name,_) = modAndOcc name - where + where + (mod_name,_) = modAndOcc name + + +rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl) -- Notice that the rnEnv starts empty - rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl) - rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl) +rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl) + +rn_data_decl (tycon_name,ty_decl) = rn_iface_decl mod_name (TyD ty_decl) + where + (mod_name, _) = modAndOcc tycon_name \end{code} +\begin{code} +reportUnusedNames explicit_avail_names + | not opt_WarnNameShadowing + = returnRn () + + | otherwise + = getSlurpedNames `thenRn` \ slurped_names -> + let + unused = explicit_avail_names `minusNameSet` slurped_names + (local_unused, imported_unused) = partition isLocallyDefined (nameSetToList unused) + imports_by_module = equivClasses cmp imported_unused + name1 `cmp` name2 = nameModule name1 `_CMP_STRING_` nameModule name2 + + pp_imp sty = sep [text "For information: the following unqualified imports are unused:", + nest 4 (vcat (map (pp_group sty) imports_by_module))] + pp_group sty (n:ns) = sep [hcat [text "Module ", pprModule PprForUser (nameModule n), char ':'], + nest 4 (sep (map (pprOccName sty . nameOccName) (n:ns)))] + + pp_local sty = sep [text "For information: the following local top-level definitions are unused:", + nest 4 (sep (map (pprOccName sty . nameOccName) local_unused))] + in + (if null imported_unused + then returnRn () + else addWarnRn pp_imp) `thenRn_` + + (if null local_unused + then returnRn () + else addWarnRn pp_local) + +nameModule n = fst (modAndOcc n) + +rnStats :: [RenamedHsDecl] -> RnMG () +rnStats all_decls + | opt_D_show_rn_trace || + opt_D_dump_rn || + opt_D_show_passes + = getRnStats all_decls `thenRn` \ msg -> + ioToRnMG (hPutStr stderr (show msg) >> + hPutStr stderr "\n") `thenRn_` + returnRn () + + | otherwise = returnRn () +\end{code} diff --git a/ghc/compiler/rename/RnBinds.hi-boot b/ghc/compiler/rename/RnBinds.hi-boot new file mode 100644 index 0000000..d879f55 --- /dev/null +++ b/ghc/compiler/rename/RnBinds.hi-boot @@ -0,0 +1,5 @@ +_interface_ RnBinds 1 +_exports_ +RnBinds rnBinds; +_declarations_ +1 rnBinds _:_ _forall_ [a b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS a (b, RnMonad.FreeVars)) -> RnMonad.RnMS a (b, RnMonad.FreeVars) ;; diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index d5183ae..766b989 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -26,10 +26,10 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, isUnboundName ) +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, newLocalNames, isUnboundName ) import CmdLineOpts ( opt_SigsRequired ) -import Digraph ( stronglyConnComp ) +import Digraph ( stronglyConnComp, SCC(..) ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name ( OccName(..), Provenance, Name {- instance Eq -}, @@ -39,12 +39,16 @@ import Name ( OccName(..), Provenance, import Maybes ( catMaybes ) --import PprStyle--ToDo:rm import Pretty -import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic ) +import Util ( Ord3(..), thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault ) import UniqSet ( SYN_IE(UniqSet) ) import ListSetOps ( minusList ) import Bag ( bagToList ) import UniqFM ( UniqFM ) import ErrUtils ( SYN_IE(Error) ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif + \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -165,8 +169,7 @@ contains bindings for the binders of this particular binding. rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds rnTopBinds EmptyBinds = returnRn EmptyBinds -rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind [] -rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs +rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs -- The parser doesn't produce other forms @@ -202,9 +205,8 @@ rnBinds :: RdrNameHsBinds -> (RenamedHsBinds -> RnMS s (result, FreeVars)) -> RnMS s (result, FreeVars) -rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds -rnBinds (SingleBind (RecBind bind)) thing_inside = rnMonoBinds bind [] thing_inside -rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside +rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds +rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside -- the parser doesn't produce other forms @@ -218,7 +220,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, -- and extend current scope, inventing new names for the new binders -- This also checks that the names form a set - bindLocatedLocalsRn "binding group" mbinders_w_srclocs $ \ new_mbinders -> + bindLocatedLocalsRn (\_ -> text "binding group") mbinders_w_srclocs $ \ new_mbinders -> let binder_set = mkNameSet new_mbinders in @@ -261,10 +263,9 @@ rn_mono_binds is_top_lev binders mbinds sigs flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) -> -- Do the SCC analysis - let vertices = mkVertices mbinds_info - edges = mkEdges mbinds_info - scc_result = stronglyConnComp (==) edges vertices - final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result) + let edges = mkEdges mbinds_info + scc_result = stronglyConnComp edges + final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) -- Deal with bound and free-var calculation rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info] @@ -279,7 +280,7 @@ unique ``vertex tags'' on its output; minor plumbing required. flattenMonoBinds :: Int -- Next free vertex tag -> [RenamedSig] -- Signatures -> RdrNameMonoBinds - -> RnMS s (Int, FlatMonoBindsInfo) + -> RnMS s (Int, [FlatMonoBindsInfo]) flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, []) @@ -346,13 +347,18 @@ rnMethodBinds (AndMonoBinds mb1 mb2) rnMethodBinds (FunMonoBind occname inf matches locn) = pushSrcLocRn locn $ mapRn (checkPrecMatch inf occname) matches `thenRn_` - lookupBndrRn occname `thenRn` \ op_name -> + + newLocalNames [(occname, locn)] `thenRn` \ [op_name] -> + -- Make a fresh local for the bound variable; it must be different + -- to occurrences of the same thing on the LHS, which refer to the global + -- selectors. + mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) -> returnRn (FunMonoBind op_name inf new_matches locn) rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn) = pushSrcLocRn locn $ - lookupBndrRn occname `thenRn` \ op_name -> + newLocalNames [(occname, locn)] `thenRn` \ [op_name] -> rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) -> returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) @@ -382,40 +388,17 @@ This @MonoBinds@- and @ClassDecls@-specific code is segregated here, as the two cases are similar. \begin{code} -reconstructCycle :: [Edge] -- Original edges - -> FlatMonoBindsInfo - -> Cycle +reconstructCycle :: SCC FlatMonoBindsInfo -> RenamedHsBinds -reconstructCycle edges mbi cycle - = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) +reconstructCycle (AcyclicSCC (_, _, _, binds, sigs)) + = MonoBind binds sigs nonRecursive + +reconstructCycle (CyclicSCC cycle) + = MonoBind this_gp_binds this_gp_sigs recursive where - relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi, - vertex `is_elem` cycle] - (binds, sig_lists) = unzip relevant_binds_and_sigs - this_gp_binds = foldr1 AndMonoBinds binds - this_gp_sigs = foldr1 (++) sig_lists - - is_elem = isIn "reconstructRec" - - mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds - mk_binds bs [] True = SingleBind (RecBind bs) - mk_binds bs ss True = BindWith (RecBind bs) ss - mk_binds bs [] False = SingleBind (NonRecBind bs) - mk_binds bs ss False = BindWith (NonRecBind bs) ss - - -- moved from Digraph, as this is the only use here - -- (avoid overloading cost). We have to use elem - -- (not FiniteMaps or whatever), because there may be - -- many edges out of one vertex. We give it its own - -- "elem" just for speed. - - isCyclic es [] = panic "isCyclic: empty component" - isCyclic es [v] = (v,v) `elem` es - isCyclic es vs = True - - elem _ [] = False - elem x (y:ys) = x==y || elem x ys + this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle] + this_gp_sigs = foldr1 (++) [sigs | (_, _, _, _, sigs) <- cycle] \end{code} %************************************************************************ @@ -431,34 +414,26 @@ renamed. \begin{code} type FlatMonoBindsInfo - = [(VertexTag, -- Identifies the vertex - NameSet, -- Set of names defined in this vertex - NameSet, -- Set of names used in this vertex - RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat) - [RenamedSig]) -- Signatures, if any, for this vertex - ] + = (VertexTag, -- Identifies the vertex + NameSet, -- Set of names defined in this vertex + NameSet, -- Set of names used in this vertex + RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat) + [RenamedSig]) -- Signatures, if any, for this vertex -mkVertices :: FlatMonoBindsInfo -> [VertexTag] -mkEdges :: FlatMonoBindsInfo -> [Edge] -mkVertices info = [ vertex | (vertex,_,_,_,_) <- info] +mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] -mkEdges flat_info -- An edge (v,v') indicates that v depends on v' - = [ (source_vertex, target_vertex) - | (source_vertex, _, used_names, _, _) <- flat_info, - target_name <- nameSetToList used_names, - target_vertex <- vertices_defining target_name flat_info +mkEdges flat_info + = [ (info, tag, dest_vertices (nameSetToList names_used)) + | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info ] - where - -- If each name only has one binding in this group, then - -- vertices_defining will always return the empty list, or a - -- singleton. The case when there is more than one binding (an - -- error) needs more thought. - - vertices_defining name flat_info2 - = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, - name `elemNameSet` names_defined - ] + where + -- An edge (v,v') indicates that v depends on v' + dest_vertices src_mentions = [ target_vertex + | (target_vertex, names_defined, _, _, _) <- flat_info, + mentioned_name <- src_mentions, + mentioned_name `elemNameSet` names_defined + ] \end{code} @@ -503,15 +478,15 @@ rnBindSigs is_toplev binders sigs renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupBndrRn v `thenRn` \ new_v -> - rnHsType ty `thenRn` \ new_ty -> + lookupBndrRn v `thenRn` \ new_v -> + rnHsSigType (\ sty -> ppr sty v) ty `thenRn` \ new_ty -> returnRn (Sig new_v new_ty src_loc) renameSig (SpecSig v ty using src_loc) = pushSrcLocRn src_loc $ lookupBndrRn v `thenRn` \ new_v -> - rnHsType ty `thenRn` \ new_ty -> - rn_using using `thenRn` \ new_using -> + rnHsSigType (\ sty -> ppr sty v) ty `thenRn` \ new_ty -> + rn_using using `thenRn` \ new_using -> returnRn (SpecSig new_v new_ty new_using src_loc) where rn_using Nothing = returnRn Nothing @@ -573,16 +548,16 @@ sig_name (MagicUnfoldingSig n _ _) = n \begin{code} dupSigDeclErr (sig:sigs) = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppPStr SLIT("more than one"), - ppPStr what_it_is, ppPStr SLIT("given for"), - ppQuote (ppr sty (sig_name sig))]) + addErrRn (\sty -> sep [ptext SLIT("more than one"), + ptext what_it_is, ptext SLIT("given for"), + ppr sty (sig_name sig)]) where (what_it_is, loc) = sig_doc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (\sty -> ppSep [ppPStr flavour, ppPStr SLIT("but no definition for"), - ppQuote (ppr sty (sig_name sig))]) + addErrRn (\sty -> sep [ptext flavour, ptext SLIT("but no definition for"), + ppr sty (sig_name sig)]) where (flavour, loc) = sig_doc sig @@ -593,9 +568,9 @@ sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc) missingSigErr var sty - = ppSep [ppPStr SLIT("a definition but no type signature for"), ppQuote (ppr sty var)] + = sep [ptext SLIT("a definition but no type signature for"), ppr sty var] methodBindErr mbind sty - = ppHang (ppPStr SLIT("Can't handle multiple methods defined by one pattern binding")) + = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) 4 (ppr sty mbind) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 1b348bc..995f15d 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,19 +21,25 @@ import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), occNameString, occNameFlavour, SYN_IE(NameSet), emptyNameSet, addListToNameSet, mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, - isWiredInName, nameOccName, setNameProvenance, isVarOcc, - pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance + nameOccName, setNameProvenance, isVarOcc, getNameProvenance, + pprProvenance, pprOccName, pprModule, pprNameProvenance, + NamedThing(..) ) import TyCon ( TyCon ) import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon ) import FiniteMap +import Outputable import Unique ( Unique, unboundKey ) +import UniqFM ( Uniquable(..) ) import Maybes ( maybeToBool ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Pretty import PprStyle ( PprStyle(..) ) -import Util ( panic, removeDups, pprTrace, assertPanic ) +import Util --( panic, removeDups, pprTrace, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import List (nub) +#endif \end{code} @@ -83,14 +89,26 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc -- If it's not in the cache we put it there with the correct provenance. -- The idea is that, after all this, the cache -- will contain a Name with the correct Provenance (i.e. Local) + -- + -- Actually, there's a catch. If this is the *second* binding for something + -- we want to allocate a *fresh* unique, rather than using the same Name as before. + -- Otherwise we don't detect conflicting definitions of the same top-level name! + -- So the only time we re-use a Name already in the cache is when it's one of + -- the Implicit magic-unique ones mentioned in the previous para let provenance = LocalDef (rec_exp_fn new_name) loc (us', us1) = splitUniqSupply us uniq = getUnique us1 key = (mod,occ) new_name = case lookupFM cache key of - Just name -> setNameProvenance name provenance - Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance + Just name | is_implicit_prov + -> setNameProvenance name provenance + where + is_implicit_prov = case getNameProvenance name of + Implicit -> True + other -> False + other -> mkGlobalName uniq mod occ VanillaDefn provenance + new_cache = addToFM cache key new_name in setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` @@ -157,15 +175,12 @@ isUnboundName name = uniqueOf name == unboundKey \end{code} \begin{code} -bindLocatedLocalsRn :: String -- Documentation string for error message +bindLocatedLocalsRn :: (PprStyle -> Doc) -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS s a) -> RnMS s a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = -- Check for use of qualified names - mapRn (qualNameErr doc_str) quals `thenRn_` - -- Check for dupicated names in a binding group - mapRn (dupNamesErr doc_str) dups `thenRn_` + = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` getNameEnv `thenRn` \ name_env -> (if opt_WarnNameShadowing @@ -181,8 +196,6 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope in setNameEnv new_name_env (enclosed_scope names) where - quals = filter (isQual.fst) rdr_names_w_loc - (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc check_shadow name_env (rdr_name,loc) = case lookupFM name_env rdr_name of Nothing -> returnRn () @@ -191,7 +204,9 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope bindLocalsRn doc_str rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope + bindLocatedLocalsRn (\_ -> text doc_str) + (rdr_names `zip` repeat loc) + enclosed_scope bindTyVarsRn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> @@ -200,6 +215,25 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replaceTyVarName tyvar_names names) + + -- Works in any variant of the renamer monad +checkDupOrQualNames, checkDupNames :: (PprStyle -> Doc) + -> [(RdrName, SrcLoc)] + -> RnM s d () + +checkDupOrQualNames doc_str rdr_names_w_loc + = -- Check for use of qualified names + mapRn (qualNameErr doc_str) quals `thenRn_` + checkDupNames doc_str rdr_names_w_loc + where + quals = filter (isQual.fst) rdr_names_w_loc + +checkDupNames doc_str rdr_names_w_loc + = -- Check for dupicated names in a binding group + mapRn (dupNamesErr doc_str) dups `thenRn_` + returnRn () + where + (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc \end{code} @@ -337,13 +371,14 @@ plusNameEnvRn n1 n2 = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_` returnRn (n1 `plusFM` n2) -addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv -addOneToNameEnvRn env rdr_name name - = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name) `thenRn_` - returnRn (addToFM env rdr_name name) +addOneToNameEnv :: NameEnv -> RdrName -> Name -> NameEnv +addOneToNameEnv env rdr_name name = addToFM env rdr_name name lookupNameEnv :: NameEnv -> RdrName -> Maybe Name lookupNameEnv = lookupFM + +delOneFromNameEnv :: NameEnv -> RdrName -> NameEnv +delOneFromNameEnv env rdr_name = delFromFM env rdr_name \end{code} =============== FixityEnv ================ @@ -352,9 +387,7 @@ plusFixityEnvRn f1 f2 = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_` returnRn (f1 `plusFM` f2) -addOneToFixityEnvRn env rdr_name fixity - = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity) `thenRn_` - returnRn (addToFM env rdr_name fixity) +addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity lookupFixityEnv env rdr_name = case lookupFM env rdr_name of @@ -364,7 +397,7 @@ lookupFixityEnv env rdr_name bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool bad_fix (f1,_) (f2,_) = f1 /= f2 -pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty +pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Doc pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov \end{code} @@ -388,6 +421,10 @@ plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) plusAvail a NotAvailable = a plusAvail NotAvailable a = a +-- Added SOF 4/97 +#ifdef DEBUG +plusAvail a1 a2 = panic ("RnEnv.plusAvail " ++ (show (hsep [pprAvail PprDebug a1,pprAvail PprDebug a2]))) +#endif addAvailToNameSet :: NameSet -> AvailInfo -> NameSet addAvailToNameSet names avail = addListToNameSet names (availNames avail) @@ -423,7 +460,7 @@ filterAvail :: RdrNameIE -- Wanted filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $ + | otherwise = pprTrace "filterAvail" (hsep [ppr PprDebug ie, pprAvail PprDebug avail]) $ NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs @@ -449,7 +486,7 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail filterAvail ie avail = NotAvailable - +{- OLD to be deleted hideAvail :: RdrNameIE -- Hide this -> AvailInfo -- Available -> AvailInfo -- Resulting available; @@ -481,15 +518,19 @@ hideAvail ie (AvailTC n ns) where keep n = nameOccName n `notElem` hide_occs hide_occs = map rdrNameOcc (hide : hides) - - --- pprAvail gets given the OccName of the "host" thing -pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable") -pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n), - ppChar '(', - ppInterleave ppComma (map (pprOccName sty.nameOccName) ns), - ppChar ')'] -pprAvail sty (Avail n) = pprOccName sty (nameOccName n) +-} + +-- In interfaces, pprAvail gets given the OccName of the "host" thing +pprAvail PprInterface avail = ppr_avail (pprOccName PprInterface . nameOccName) avail +pprAvail sty avail = ppr_avail (ppr sty) avail + +ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") +ppr_avail pp_name (AvailTC n ns) = hsep [ + pp_name n, + parens $ hsep $ punctuate comma $ + map pp_name ns + ] +ppr_avail pp_name (Avail n) = pp_name n \end{code} @@ -533,35 +574,36 @@ conflictFM bad fm key elt \begin{code} nameClashErr (rdr_name, (name1,name2)) sty - = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name]) - 4 (ppAboves [pprNameProvenance sty name1, + = hang (hsep [ptext SLIT("Conflicting definitions for: "), ppr sty rdr_name]) + 4 (vcat [pprNameProvenance sty name1, pprNameProvenance sty name2]) fixityClashErr (rdr_name, (fp1,fp2)) sty - = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name]) - 4 (ppAboves [pprFixityProvenance sty fp1, + = hang (hsep [ptext SLIT("Conflicting fixities for: "), ppr sty rdr_name]) + 4 (vcat [pprFixityProvenance sty fp1, pprFixityProvenance sty fp2]) shadowedNameWarn shadow sty - = ppBesides [ppPStr SLIT("This binding for"), - ppQuote (ppr sty shadow), - ppPStr SLIT("shadows an existing binding")] + = hcat [ptext SLIT("This binding for"), + ppr sty shadow, + ptext SLIT("shadows an existing binding")] unknownNameErr name sty - = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name] + = sep [text flavour, ptext SLIT("not in scope:"), ppr sty name] where flavour = occNameFlavour (rdrNameOcc name) qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "), - ppStr descriptor, ppPStr SLIT(": "), - pprNonSymOcc sty (rdrNameOcc name) ]) + addErrRn (\sty -> hsep [ ptext SLIT("invalid use of qualified name"), + ppr sty name, + ptext SLIT("in"), + descriptor sty]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"), - ppr sty name, ppPStr SLIT("' in "), - ppStr descriptor]) + addErrRn (\sty -> hsep [ptext SLIT("duplicate bindings of"), + ppr sty name, + ptext SLIT("in"), descriptor sty]) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index e1e6fe2..8462995 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -25,9 +25,10 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnEnv +import CmdLineOpts ( opt_GlasgowExts ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, - negate_RDR + ratioDataCon_RDR, negate_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -37,7 +38,6 @@ import Id ( GenId ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name import Pretty -import Unique ( Unique, otherwiseIdKey ) import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, @@ -45,6 +45,8 @@ import UniqSet ( emptyUniqSet, unitUniqSet, ) import PprStyle ( PprStyle(..) ) import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) +import Outputable + \end{code} @@ -136,7 +138,7 @@ rnPat (RecPatIn con rpats) ************************************************************************ \begin{code} -rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) +--rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) rnMatch (PatMatch pat match) = bindLocalsRn "pattern" binders $ \ new_binders -> @@ -158,7 +160,7 @@ rnMatch (GRHSMatch grhss_and_binds) %************************************************************************ \begin{code} -rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars) +--rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars) rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) = rnBinds binds $ \ binds' -> @@ -174,22 +176,30 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) rnGRHS (GRHS guard expr locn) = pushSrcLocRn locn $ - rnExpr guard `thenRn` \ (guard', fvsg) -> - rnExpr expr `thenRn` \ (expr', fvse) -> + (if not (opt_GlasgowExts || is_standard_guard guard) then + addWarnRn (nonStdGuardErr guard) + else + returnRn () + ) `thenRn_` - -- Turn an "otherwise" guard into an OtherwiseGRHS. - -- This is the first moment that we can be sure we havn't got a shadowed binding - -- of "otherwise". - let grhs' = case guard' of - HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn - other -> GRHS guard' expr' locn - in - returnRn (grhs', fvsg `unionNameSets` fvse) + (rnStmts rnExpr guard $ \ guard' -> + -- This nested thing deals with scope and + -- the free vars of the guard, and knocking off the + -- free vars of the rhs that are bound by the guard + + rnExpr expr `thenRn` \ (expr', fvse) -> + returnRn (GRHS guard' expr' locn, fvse)) rnGRHS (OtherwiseGRHS expr locn) = pushSrcLocRn locn $ rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn (OtherwiseGRHS expr' locn, fvs) + returnRn (GRHS [] expr' locn, fvs) + + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [GuardStmt _ _] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -199,7 +209,7 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) +--rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls [] `thenRn` \ (exprs, fvExprs) -> returnRn (exprs, unionManyNameSets fvExprs) @@ -301,8 +311,8 @@ rnExpr (HsLet binds expr) rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too - rnStmts stmts `thenRn` \ (stmts', fvStmts) -> - returnRn (HsDo do_or_lc stmts' src_loc, fvStmts) + (rnStmts rnExpr stmts $ \ stmts' -> + returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet)) rnExpr (ExplicitList exps) = addImplicitOccRn listType_name `thenRn_` @@ -325,8 +335,8 @@ rnExpr (RecordUpd expr rbinds) returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsType pty `thenRn` \ pty' -> + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' -> returnRn (ExprWithTySig expr' pty', fvExpr) rnExpr (HsIf p b1 b2 src_loc) @@ -413,22 +423,27 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars) +type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) -rnStmts [] = returnRn ([], emptyNameSet) +rnStmts :: RnExprTy s + -> [RdrNameStmt] + -> ([RenamedStmt] -> RnMS s (a, FreeVars)) + -> RnMS s (a, FreeVars) -rnStmts (stmt:stmts) - = rnStmt stmt $ \ stmt' -> - rnStmts stmts `thenRn` \ (stmts', fv_stmts) -> - returnRn (stmt':stmts', fv_stmts) +rnStmts rn_expr [] thing_inside + = thing_inside [] +rnStmts rn_expr (stmt:stmts) thing_inside + = rnStmt rn_expr stmt $ \ stmt' -> + rnStmts rn_expr stmts $ \ stmts' -> + thing_inside (stmt' : stmts') --- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars) --- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] +rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars) +-- Because of mutual recursion we have to pass in rnExpr. -rnStmt (BindStmt pat expr src_loc) thing_inside +rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + rn_expr expr `thenRn` \ (expr', fv_expr) -> bindLocalsRn "pattern in do binding" binders $ \ new_binders -> rnPat pat `thenRn` \ pat' -> @@ -437,24 +452,24 @@ rnStmt (BindStmt pat expr src_loc) thing_inside where binders = collectPatBinders pat -rnStmt (ExprStmt expr src_loc) thing_inside +rnStmt rn_expr (ExprStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) -rnStmt (GuardStmt expr src_loc) thing_inside +rnStmt rn_expr (GuardStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) -rnStmt (ReturnStmt expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> +rnStmt rn_expr (ReturnStmt expr) thing_inside + = rn_expr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) -rnStmt (LetStmt binds) thing_inside +rnStmt rn_expr (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') \end{code} @@ -489,20 +504,28 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) returnRn (OpApp e11 op1 fix1 new_e) where (nofix_error, rearrange_me) = compareFixity fix1 fix2 - get (HsVar n) = n -mkOpAppRn e1@(NegApp neg_arg neg_id) +mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2@(Fixity prec2 dir2) e2 - | prec2 > 6 -- Precedence of unary - is wired in as 6! + | nofix_error + = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_` + returnRn (OpApp e1 op2 fix2 e2) + + | rearrange_me = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_id) + returnRn (NegApp new_e neg_op) + where + fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6! + (nofix_error, rearrange_me) = compareFixity fix_neg fix2 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT( right_op_ok fix e2 ) returnRn (OpApp e1 op fix e2) +get (HsVar n) = n + -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operarand. So we just check that the right operand is OK @@ -514,9 +537,9 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator -mkNegAppRn mode neg_arg neg_id +mkNegAppRn mode neg_arg neg_op = ASSERT( not_op_app mode neg_arg ) - returnRn (NegApp neg_arg neg_id) + returnRn (NegApp neg_arg neg_op) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True @@ -640,8 +663,12 @@ litOccurrence (HsInt _) = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational - + = lookupImplicitOccRn fractionalClass_RDR `thenRn_` + lookupImplicitOccRn ratioDataCon_RDR + -- We have to make sure that the Ratio type is imported with + -- its constructor, because literals of type Ratio t are + -- built with that constructor. + litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -664,23 +691,27 @@ litOccurrence (HsLitLit _) \begin{code} dupFieldErr str (dup:rest) sty - = ppBesides [ppPStr SLIT("duplicate field name `"), + = hcat [ptext SLIT("duplicate field name `"), ppr sty dup, - ppPStr SLIT("' in record "), ppStr str] + ptext SLIT("' in record "), text str] negPatErr pat sty - = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] + = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] precParseNegPatErr op sty - = ppHang (ppPStr SLIT("precedence parsing error")) - 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "), + = hang (ptext SLIT("precedence parsing error")) + 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "), pp_op sty op, - ppPStr SLIT(" in pattern")]) + ptext SLIT(" in pattern")]) precParseErr op1 op2 sty - = ppHang (ppPStr SLIT("precedence parsing error")) - 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2, - ppPStr SLIT(" in the same infix expression")]) + = hang (ptext SLIT("precedence parsing error")) + 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2, + ptext SLIT(" in the same infix expression")]) + +nonStdGuardErr guard sty + = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) + 4 (ppr sty guard) -pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen] +pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)] \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 953d8ad..5d8e019 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,6 +11,9 @@ module RnHsSyn where IMP_Ubiq() import HsSyn +#if __GLASGOW_HASKELL__ >= 202 +import HsPragmas +#endif import Id ( GenId, SYN_IE(Id) ) import Name ( Name ) @@ -28,7 +31,6 @@ import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} ) \begin{code} type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat -type RenamedBind = Bind Fake Fake Name RenamedPat type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 453fda3..97d1edc 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -9,9 +9,9 @@ module RnIfaces ( getInterfaceExports, getImportedInstDecls, - getSpecialInstModules, + getSpecialInstModules, getDeferredDataDecls, importDecl, recordSlurp, - getImportVersions, + getImportVersions, getSlurpedNames, getRnStats, checkUpToDate, @@ -20,63 +20,150 @@ module RnIfaces ( ) where IMP_Ubiq() +#if __GLASGOW_HASKELL__ >= 202 +import IO +#endif -import CmdLineOpts ( opt_HiSuffix, opt_HiSuffixPrelude ) -import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsType(..), - HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), BangType, IfaceSig(..), +import CmdLineOpts ( opt_TyConPruning ) +import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, HsExpr, Sig(..), HsType(..), + HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), ConDetails(..), BangType, IfaceSig(..), FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo, - IE(..) + IE(..), NewOrData(..), hsDeclName ) import HsPragmas ( noGenPragmas ) -import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), +import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl), RdrName, rdrNameOcc ) import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet, pprAvail ) -import RnSource ( rnHsType ) +import RnSource ( rnHsSigType ) import RnMonad +import RnHsSyn ( SYN_IE(RenamedHsDecl) ) import ParseIface ( parseIface ) import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) -import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList ) +import FiniteMap ( FiniteMap, sizeFM, emptyFM, unitFM, delFromFM, + lookupFM, addToFM, addToFM_C, addListToFM, + fmToList, eltsFM + ) import Name ( Name {-instance NamedThing-}, Provenance, OccName(..), - modAndOcc, occNameString, moduleString, pprModule, + modAndOcc, occNameString, moduleString, pprModule, isLocallyDefined, NameSet(..), emptyNameSet, unionNameSets, nameSetToList, - minusNameSet, mkNameSet, elemNameSet, - isWiredInName, maybeWiredInTyConName, maybeWiredInIdName + minusNameSet, mkNameSet, elemNameSet, nameUnique, + isWiredInName, maybeWiredInTyConName, maybeWiredInIdName, + NamedThing(..) ) import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon ) import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) import Type ( namesOfType ) import TyVar ( GenTyVar ) -import SrcLoc ( mkIfaceSrcLoc ) -import PrelMods ( gHC__, isPreludeModule ) +import SrcLoc ( mkIfaceSrcLoc, SrcLoc ) +import PrelMods ( gHC__ ) +import PrelInfo ( cCallishTyKeys ) import Bag import Maybes ( MaybeErr(..), expectJust, maybeToBool ) import ListSetOps ( unionLists ) import Pretty import PprStyle ( PprStyle(..) ) -import Util ( pprPanic, pprTrace ) +import Unique ( Unique ) +import Util ( pprPanic, pprTrace, Ord3(..) ) import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer ) - +import Outputable \end{code} %********************************************************* %* * +\subsection{Statistics} +%* * +%********************************************************* + +\begin{code} +getRnStats :: [RenamedHsDecl] -> RnMG Doc +getRnStats all_decls + = getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces + n_mods = sizeFM mod_vers_map + + decls_imported = filter is_imported_decl all_decls + decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm, + name == availName avail, + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + not (isLocallyDefined name) + ] + + (cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd, _) = count_decls decls_read + (cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported + + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <> text " interfaces read", + hsep [int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [int dd_sp, text "data decls imported (of which", int add_sp, text "abstractly), out of", + int dd_rd, text "read"], + hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"] + ] + in + returnRn (hcat [text "Renamer stats: ", stats]) + +is_imported_decl (DefD _) = False +is_imported_decl (ValD _) = False +is_imported_decl decl = not (isLocallyDefined (hsDeclName decl)) + +count_decls decls + = -- pprTrace "count_decls" (ppr PprDebug decls + -- + -- $$ + -- text "=========" + -- $$ + -- ppr PprDebug imported_decls + -- ) $ + (class_decls, + data_decls, abstract_data_decls, + newtype_decls, abstract_newtype_decls, + syn_decls, + val_decls, + inst_decls) + where + class_decls = length [() | ClD _ <- decls] + data_decls = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls] + newtype_decls = length [() | TyD (TyData NewType _ _ _ _ _ _ _) <- decls] + abstract_data_decls = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls] + abstract_newtype_decls = length [() | TyD (TyData NewType _ _ _ [] _ _ _) <- decls] + syn_decls = length [() | TyD (TySynonym _ _ _ _) <- decls] + val_decls = length [() | SigD _ <- decls] + inst_decls = length [() | InstD _ <- decls] + +\end{code} + +%********************************************************* +%* * \subsection{Loading a new interface file} %* * %********************************************************* \begin{code} -loadInterface :: Pretty -> Module -> RnMG Ifaces +loadInterface :: Doc -> Module -> RnMG Ifaces loadInterface doc_str load_mod = getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts inst_mods = ifaces + Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts deferred_data_decls inst_mods = ifaces in -- CHECK WHETHER WE HAVE IT ALREADY if maybeToBool (lookupFM export_envs load_mod) @@ -94,7 +181,7 @@ loadInterface doc_str load_mod new_export_envs = addToFM export_envs load_mod ([],[]) new_ifaces = Ifaces this_mod mod_vers_map new_export_envs - decls all_names imp_names insts inst_mods + decls all_names imp_names insts deferred_data_decls inst_mods in setIfacesRn new_ifaces `thenRn_` failWithRn new_ifaces (noIfaceErr load_mod) ; @@ -118,6 +205,7 @@ loadInterface doc_str load_mod new_decls all_names imp_names new_insts + deferred_data_decls new_inst_mods in setIfacesRn new_ifaces `thenRn_` @@ -178,7 +266,7 @@ loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_lo -- We find the gates by renaming the instance type with in a -- and returning the occurrence pool. initRnMS emptyRnEnv mod_name InterfaceMode ( - findOccurrencesRn (rnHsType munged_inst_ty) + findOccurrencesRn (rnHsSigType (\sty -> text "an instance decl") munged_inst_ty) ) `thenRn` \ gate_names -> returnRn (((mod_name, decl), gate_names) `consBag` insts) \end{code} @@ -196,7 +284,7 @@ checkUpToDate mod_name = findAndReadIface doc_str mod_name `thenRn` \ read_result -> case read_result of Nothing -> -- Old interface file not found, so we'd better bail out - traceRn (ppSep [ppPStr SLIT("Didnt find old iface"), + traceRn (sep [ptext SLIT("Didnt find old iface"), pprModule PprDebug mod_name]) `thenRn_` returnRn False @@ -205,15 +293,14 @@ checkUpToDate mod_name checkModUsage usages where -- Only look in current directory, with suffix .hi - doc_str = ppSep [ppPStr SLIT("Need usage info from"), pprModule PprDebug mod_name] - + doc_str = sep [ptext SLIT("Need usage info from"), pprModule PprDebug mod_name] checkModUsage [] = returnRn True -- Yes! Everything is up to date! checkModUsage ((mod, old_mod_vers, old_local_vers) : rest) = loadInterface doc_str mod `thenRn` \ ifaces -> let - Ifaces _ mod_vers _ decls _ _ _ _ = ifaces + Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces maybe_new_mod_vers = lookupFM mod_vers mod Just new_mod_vers = maybe_new_mod_vers in @@ -225,20 +312,20 @@ checkModUsage ((mod, old_mod_vers, old_local_vers) : rest) -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (ppSep [ppPStr SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_` checkModUsage rest else - traceRn (ppSep [ppPStr SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_` + traceRn (sep [ptext SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_` -- New module version, so check entities inside checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date -> if up_to_date then - traceRn (ppPStr SLIT("...but the bits I use haven't.")) `thenRn_` + traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else returnRn False -- This one failed, so just bail out now where - doc_str = ppSep [ppPStr SLIT("need version info for"), pprModule PprDebug mod] + doc_str = sep [ptext SLIT("need version info for"), pprModule PprDebug mod] checkEntityUsage mod decls [] @@ -249,7 +336,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) case lookupFM decls name of Nothing -> -- We used it before, but it ain't there now - traceRn (ppSep [ppPStr SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_` + traceRn (sep [ptext SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_` returnRn False Just (new_vers,_,_) -- It's there, but is it up to date? @@ -259,7 +346,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out - -> traceRn (ppSep [ppPStr SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_` + -> traceRn (sep [ptext SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_` returnRn False \end{code} @@ -277,7 +364,7 @@ importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) importDecl name necessity = checkSlurped name `thenRn` \ already_slurped -> if already_slurped then - -- traceRn (ppSep [ppStr "Already slurped:", ppr PprDebug name]) `thenRn_` + -- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_` returnRn Nothing -- Already dealt with else if isWiredInName name then @@ -285,7 +372,7 @@ importDecl name necessity else getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod _ _ _ _ _ _ _ = ifaces + Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces (mod,_) = modAndOcc name in if mod == this_mod then -- Don't bring in decls from @@ -294,28 +381,37 @@ importDecl name necessity -- else getNonWiredInDecl name necessity - \end{code} \begin{code} getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) -getNonWiredInDecl name necessity +getNonWiredInDecl needed_name necessity = traceRn doc_str `thenRn_` - loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _) -> - case lookupFM decls name of + loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) -> + case lookupFM decls needed_name of + + -- Special case for data/newtype type declarations + Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl + -> getNonWiredDataDecl needed_name version avail ty_decl `thenRn` \ (avail', maybe_decl) -> + recordSlurp (Just version) avail' `thenRn_` + returnRn maybe_decl - Just (version,avail,decl) -> recordSlurp (Just version) avail `thenRn_` - returnRn (Just decl) + Just (version,avail,decl) + -> recordSlurp (Just version) avail `thenRn_` + returnRn (Just decl) Nothing -> -- Can happen legitimately for "Optional" occurrences case necessity of { - Optional -> addWarnRn (getDeclWarn name); - other -> addErrRn (getDeclErr name) + Optional -> addWarnRn (getDeclWarn needed_name); + other -> addErrRn (getDeclErr needed_name) } `thenRn_` returnRn Nothing where - doc_str = ppSep [ppPStr SLIT("Need decl for"), ppr PprDebug name] - (mod,_) = modAndOcc name + doc_str = sep [ptext SLIT("Need decl for"), ppr PprDebug needed_name] + (mod,_) = modAndOcc needed_name + + is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True + is_data_or_newtype other = False \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -364,7 +460,7 @@ getWiredInDecl name main_name = availName avail main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False } (mod,_) = modAndOcc main_name - doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name] + doc_str = sep [ptext SLIT("Need home module for wired in thing"), ppr PprDebug name] in (if not main_is_tc || mod == gHC__ then returnRn () @@ -401,10 +497,11 @@ get_wired_id id get_wired_tycon tycon | isSynTyCon tycon = addImplicitOccsRn (nameSetToList mentioned) `thenRn_` - returnRn (Avail (getName tycon)) + returnRn (AvailTC tc_name [tc_name]) where + tc_name = getName tycon (tyvars,ty) = getSynTyConDefn tycon - mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) + mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars) get_wired_tycon tycon | otherwise -- data or newtype @@ -417,41 +514,17 @@ get_wired_tycon tycon \end{code} -\begin{code} -checkSlurped name - = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _) -> - returnRn (name `elemNameSet` slurped_names) - -recordSlurp maybe_version avail - = -- traceRn (ppSep [ppStr "Record slurp:", pprAvail PprDebug avail]) `thenRn_` - getIfacesRn `thenRn` \ ifaces -> - let - Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces - new_slurped_names = addAvailToNameSet slurped_names avail - - new_imp_names = case maybe_version of - Just version -> (availName avail, version) : imp_names - Nothing -> imp_names - - new_ifaces = Ifaces this_mod mod_vers export_envs decls - new_slurped_names - new_imp_names - insts - inst_mods - in - setIfacesRn new_ifaces -\end{code} %********************************************************* %* * -\subsection{Getting other stuff} +\subsection{Getting what a module exports} %* * %********************************************************* \begin{code} getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)]) getInterfaceExports mod - = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _) -> + = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) -> case lookupFM export_envs mod of Nothing -> -- Not there; it must be that the interface file wasn't found; -- the error will have been reported already. @@ -461,9 +534,92 @@ getInterfaceExports mod Just stuff -> returnRn stuff where - doc_str = ppSep [pprModule PprDebug mod, ppPStr SLIT("is directly imported")] + doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")] +\end{code} + + +%********************************************************* +%* * +\subsection{Data type declarations are handled specially} +%* * +%********************************************************* + +Data type declarations get special treatment. If we import a data type decl +with all its constructors, we end up importing all the types mentioned in +the constructors' signatures, and hence {\em their} data type decls, and so on. +In effect, we get the transitive closure of data type decls. Worse, this drags +in tons on instance decls, and their unfoldings, and so on. +If only the type constructor is mentioned, then all this is a waste of time. +If any of the data constructors are mentioned then we really have to +drag in the whole declaration. +So when we import the type constructor for a @data@ or @newtype@ decl, we +put it in the "deferred data/newtype decl" pile in Ifaces. Right at the end +we slurp these decls, if they havn't already been dragged in by an occurrence +of a constructor. + +\begin{code} +getNonWiredDataDecl needed_name + version + avail@(AvailTC tycon_name _) + ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) + | needed_name == tycon_name + && opt_TyConPruning + && not (nameUnique needed_name `elem` cCallishTyKeys) -- Hack! Don't prune these tycons whose constructors + -- the desugarer must be able to see when desugaring + -- a CCall. Ugh! + = -- Need the type constructor; so put it in the deferred set for now + getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces + new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods + + no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc + new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl + -- Nota bene: we nuke both the constructors and the context in the deferred decl. + -- If we don't nuke the context then renaming the deferred data decls can give + -- new unresolved names (for the classes). This could be handled, but there's + -- no point. If the data type is completely abstract then we aren't interested + -- its context. + in + setIfacesRn new_ifaces `thenRn_` + returnRn (AvailTC tycon_name [tycon_name], Nothing) + + | otherwise + = -- Need a data constructor, so delete the data decl from the deferred set if it's there + getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces + new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods + + new_deferred_data_decls = delFromFM deferred_data_decls tycon_name + in + setIfacesRn new_ifaces `thenRn_` + returnRn (avail, Just (TyD ty_decl)) +\end{code} + +\begin{code} +getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)] +getDeferredDataDecls + = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) -> + let + deferred_list = fmToList deferred_data_decls + trace_msg = hang (text "Slurping abstract data/newtype decls for: ") + 4 (ppr PprDebug (map fst deferred_list)) + in + traceRn trace_msg `thenRn_` + returnRn deferred_list +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations are handled specially} +%* * +%********************************************************* + +\begin{code} getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)] getImportedInstDecls = -- First load any special-instance modules that aren't aready loaded @@ -475,7 +631,7 @@ getImportedInstDecls -- removing them from the bag kept in Ifaces getIfacesRn `thenRn` \ ifaces -> let - Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces + Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces -- An instance decl is ungated if all its gates have been slurped select_ungated :: IfaceInst -- A gated inst decl @@ -497,24 +653,32 @@ getImportedInstDecls new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (listToBag still_gated_insts) + deferred_data_decls inst_mods in setIfacesRn new_ifaces `thenRn_` returnRn un_gated_insts where load_it mod = loadInterface (doc_str mod) mod - doc_str mod = ppSep [pprModule PprDebug mod, ppPStr SLIT("is a special-instance module")] + doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")] getSpecialInstModules :: RnMG [Module] getSpecialInstModules = getIfacesRn `thenRn` \ ifaces -> let - Ifaces _ _ _ _ _ _ _ inst_mods = ifaces + Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces in returnRn inst_mods \end{code} + +%********************************************************* +%* * +\subsection{Keeping track of what we've slurped, and version numbers} +%* * +%********************************************************* + getImportVersions figures out what the "usage information" for this moudule is; that is, what it must record in its interface file as the things it uses. It records: @@ -560,7 +724,7 @@ getImportVersions :: Module -- Name of this module getImportVersions this_mod exports = getIfacesRn `thenRn` \ ifaces -> let - Ifaces _ mod_versions_map _ _ _ imp_names _ _ = ifaces + Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod) -- mv_map groups together all the things imported from a particular module. @@ -590,6 +754,41 @@ getImportVersions this_mod exports add_mod mv_map mod = addToFM mv_map mod [] \end{code} +\begin{code} +checkSlurped name + = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) -> + returnRn (name `elemNameSet` slurped_names) + +getSlurpedNames :: RnMG NameSet +getSlurpedNames + = getIfacesRn `thenRn` \ ifaces -> + let + Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces + in + returnRn slurped_names + +recordSlurp maybe_version avail + = -- traceRn (sep [text "Record slurp:", pprAvail PprDebug avail]) `thenRn_` + getIfacesRn `thenRn` \ ifaces -> + let + Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts deferred_data_decls inst_mods = ifaces + new_slurped_names = addAvailToNameSet slurped_names avail + + new_imp_names = case maybe_version of + Just version -> (availName avail, version) : imp_names + Nothing -> imp_names + + new_ifaces = Ifaces this_mod mod_vers export_envs decls + new_slurped_names + new_imp_names + insts + deferred_data_decls + inst_mods + in + setIfacesRn new_ifaces +\end{code} + + %********************************************************* %* * \subsection{Getting binders out of a declaration} @@ -608,19 +807,14 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function -> RdrNameHsDecl -> RnMG AvailInfo -getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc)) +getDeclBinders new_name (TyD (TyData _ _ tycon _ condecls _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> returnRn (AvailTC tycon_name (tycon_name : sub_names)) -getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc)) - = new_name tycon src_loc `thenRn` \ tycon_name -> - new_name con src_loc `thenRn` \ con_name -> - returnRn (AvailTC tycon_name [tycon_name, con_name]) - getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> - returnRn (Avail tycon_name) + returnRn (AvailTC tycon_name [tycon_name]) getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> @@ -635,28 +829,18 @@ getDeclBinders new_name (DefD _) = returnRn NotAvailable getDeclBinders new_name (InstD _) = returnRn NotAvailable ---------------- -getConFieldNames new_name (ConDecl con _ src_loc : rest) - = new_name con src_loc `thenRn` \ n -> - getConFieldNames new_name rest `thenRn` \ ns -> - returnRn (n:ns) - -getConFieldNames new_name (NewConDecl con _ src_loc : rest) - = new_name con src_loc `thenRn` \ n -> - getConFieldNames new_name rest `thenRn` \ ns -> - returnRn (n:ns) - -getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest) - = new_name con src_loc `thenRn` \ n -> - getConFieldNames new_name rest `thenRn` \ ns -> - returnRn (n:ns) - -getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest) +getConFieldNames new_name (ConDecl con _ (RecCon fielddecls) src_loc : rest) = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs -> getConFieldNames new_name rest `thenRn` \ ns -> returnRn (cfs ++ ns) where fields = concat (map fst fielddecls) +getConFieldNames new_name (ConDecl con _ _ src_loc : rest) + = new_name con src_loc `thenRn` \ n -> + getConFieldNames new_name rest `thenRn` \ ns -> + returnRn (n:ns) + getConFieldNames new_name [] = returnRn [] getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc @@ -670,36 +854,29 @@ getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc %********************************************************* \begin{code} -findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface) +findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -findAndReadIface doc_str mod +findAndReadIface doc_str filename = traceRn trace_msg `thenRn_` getSearchPathRn `thenRn` \ dirs -> try dirs dirs where - trace_msg = ppHang (ppBesides [ppPStr SLIT("Reading interface for "), - pprModule PprDebug mod, ppSemi]) - 4 (ppBesides [ppPStr SLIT("reason: "), doc_str]) - - mod_str = moduleString mod - hisuf = - if isPreludeModule mod then - case opt_HiSuffixPrelude of { Just hisuf -> hisuf; _ -> ".hi"} - else - case opt_HiSuffix of {Just hisuf -> hisuf; _ -> ".hi"} - - try all_dirs [] = traceRn (ppPStr SLIT("...failed")) `thenRn_` + trace_msg = hang (hcat [ptext SLIT("Reading interface for "), + ptext filename, semi]) + 4 (hcat [ptext SLIT("reason: "), doc_str]) + + try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_` returnRn Nothing - try all_dirs (dir:dirs) + try all_dirs ((dir,hisuf):dirs) = readIface file_path `thenRn` \ read_result -> case read_result of Nothing -> try all_dirs dirs - Just iface -> traceRn (ppPStr SLIT("...done")) `thenRn_` + Just iface -> traceRn (ptext SLIT("...done")) `thenRn_` returnRn (Just iface) where - file_path = dir ++ "/" ++ moduleString mod ++ hisuf + file_path = dir ++ "/" ++ moduleString filename ++ hisuf \end{code} @readIface@ trys just one file. @@ -718,28 +895,41 @@ readIface file_path Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ -> returnRn (Just iface) +#if __GLASGOW_HASKELL__ >= 202 + Left err -> + if isDoesNotExistError err then + returnRn Nothing + else + failWithRn Nothing (cannaeReadFile file_path err) +#else /* 2.01 and 0.2x */ Left (NoSuchThing _) -> returnRn Nothing Left err -> failWithRn Nothing (cannaeReadFile file_path err) +#endif \end{code} -mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into -a list of directories. For example: +mkSearchPath takes a string consisting of a colon-separated list of directories and corresponding +suffixes, and turns it into a list of (directory, suffix) pairs. For example: - mkSearchPath "foo:.:baz" = ["foo", ".", "baz"] +\begin{verbatim} + mkSearchPath "foo%.hi:.%.p_hi:baz%.mc_hi" = [("foo",".hi"),( ".", ".p_hi"), ("baz",".mc_hi")] +\begin{verbatim} \begin{code} mkSearchPath :: Maybe String -> SearchPath -mkSearchPath Nothing = ["."] +mkSearchPath Nothing = [(".",".hi")] mkSearchPath (Just s) = go s where - go "" = [] - go s = first : go (drop 1 rest) - where - (first,rest) = span (/= ':') s + go s = + case span (/= '%') s of + (dir,'%':rs) -> + case span (/= ':') rs of + (hisuf,_:rest) -> (dir,hisuf):go rest + (hisuf,[]) -> [(dir,hisuf)] + \end{code} %********************************************************* @@ -749,16 +939,16 @@ mkSearchPath (Just s) %********************************************************* \begin{code} -noIfaceErr mod sty - = ppBesides [ppPStr SLIT("Could not find valid interface file for "), ppQuote (pprModule sty mod)] --- , ppStr " in"]) 4 (ppAboves (map ppStr dirs)) +noIfaceErr filename sty + = hcat [ptext SLIT("Could not find valid interface file "), quotes (pprModule sty filename)] +-- , text " in"]) 4 (vcat (map text dirs)) cannaeReadFile file err sty - = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppPStr SLIT("; error="), ppStr (show err)] + = hcat [ptext SLIT("Failed in reading file: "), text file, ptext SLIT("; error="), text (show err)] getDeclErr name sty - = ppSep [ppPStr SLIT("Failed to find interface decl for"), ppr sty name] + = sep [ptext SLIT("Failed to find interface decl for"), ppr sty name] getDeclWarn name sty - = ppSep [ppPStr SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name] + = sep [ptext SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name] \end{code} diff --git a/ghc/compiler/rename/RnLoop.hs b/ghc/compiler/rename/RnLoop.hs new file mode 100644 index 0000000..cd65e6e --- /dev/null +++ b/ghc/compiler/rename/RnLoop.hs @@ -0,0 +1,10 @@ +module RnLoop + + ( + module RnBinds, + module RnSource + + ) where + +import RnBinds +import RnSource diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi index 8aa729d..64afc0d 100644 --- a/ghc/compiler/rename/RnLoop.lhi +++ b/ghc/compiler/rename/RnLoop.lhi @@ -7,14 +7,17 @@ import RdrHsSyn ( RdrNameHsBinds(..), RdrNameHsType(..) ) import RnHsSyn ( RenamedHsBinds(..), RenamedHsType(..) ) import RnBinds ( rnBinds ) import RnMonad ( RnMS(..), FreeVars ) -import RnSource ( rnHsType ) +import RnSource ( rnHsSigType ) import UniqSet ( UniqSet(..) ) +import PprStyle ( PprStyle ) +import Pretty ( Doc ) import Name ( Name ) rnBinds :: RdrNameHsBinds -> (RenamedHsBinds -> RnMS s (result, FreeVars)) -> RnMS s (result, FreeVars) -rnHsType :: RdrNameHsType - -> RnMS s RenamedHsType +rnHsSigType :: (PprStyle -> Doc) + -> RdrNameHsType + -> RnMS s RenamedHsType \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 8a3ebf6..2c56805 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -25,7 +25,17 @@ module RnMonad( IMP_Ubiq(){-uitous-} import SST +#if __GLASGOW_HASKELL__ <= 201 import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST ) +#define MkIO +#else +import GlaExts +import IO +import ST +import IOBase +#define IOError13 IOError +#define MkIO IO +#endif import HsSyn import RdrHsSyn @@ -48,6 +58,9 @@ import FiniteMap ( FiniteMap, emptyFM, bagToFM ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import UniqSet import Util +#if __GLASGOW_HASKELL__ >= 202 +import UniqSupply +#endif infixr 9 `thenRn`, `thenRn_` \end{code} @@ -69,15 +82,16 @@ infixr 9 `thenRn`, `thenRn_` \begin{code} sstToIO :: SST REAL_WORLD r -> IO r -sstToIO sst - = sstToST sst `thenStrictlyST` \ r -> - returnStrictlyST (Right r) +sstToIO sst = + MkIO ( + sstToST sst `thenStrictlyST` \ r -> + returnStrictlyST (Right r)) ioToRnMG :: IO r -> RnMG (Either IOError13 r) -ioToRnMG io rn_down g_down = stToSST io +ioToRnMG (MkIO io) rn_down g_down = stToSST io -traceRn :: Pretty -> RnMG () -traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >> +traceRn :: Doc -> RnMG () +traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (show msg) >> hPutStr stderr "\n") `thenRn_` returnRn () | otherwise = returnRn () @@ -128,7 +142,8 @@ data SDown s = SDown data RnSMode = SourceMode | InterfaceMode -type SearchPath = [String] -- List of directories to seach for interface files +type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search + -- for interface files. type FreeVars = NameSet \end{code} @@ -171,7 +186,7 @@ data AvailInfo = NotAvailable | AvailTC Name -- The name of the type or class [Name] -- The available pieces of type/class. NB: If the type or -- class is itself to be in scope, it must be in this list. - -- Thus, typically: Avail Eq [Eq, ==, /=] + -- Thus, typically: AvailTC Eq [Eq, ==, /=] \end{code} =================================================== @@ -212,16 +227,24 @@ data Ifaces = Ifaces -- whether locally defined or not) that have been slurped in so far. [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that - -- have been slurped in so far, with their versions. Subset of - -- the previous field. This is used to generate the "usage" information - -- for this module. + -- have been slurped in so far, with their versions. + -- This is used to generate the "usage" information for this module. + -- Subset of the previous field. - (Bag IfaceInst) -- Un-slurped instance decls; this bag is depleted when we + (Bag IfaceInst) -- The as-yet un-slurped instance decls; this bag is depleted when we -- slurp an instance decl so that we don't slurp the same one twice. + (FiniteMap Name RdrNameTyDecl) + -- Deferred data type declarations; each has the following properties + -- * it's a data type decl + -- * its TyCon is needed + -- * the decl may or may not have been slurped, depending on whether any + -- of the constrs are needed. + [Module] -- Set of modules with "special" instance declarations -- Excludes this module + type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl) type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl [Name]) -- "Gate" names. Slurp this instance decl when this @@ -268,7 +291,7 @@ initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down emptyIfaces :: Module -> Ifaces -emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag [] +emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag emptyFM [] builtins :: FiniteMap (Module,OccName) Name builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames) @@ -326,7 +349,7 @@ renameSourceCode mod_name name_supply m returnSST result ) where - display errs = ppShow 80 (pprBagOfErrors PprDebug errs) + display errs = show (pprBagOfErrors PprDebug errs) {-# INLINE thenRn #-} {-# INLINE thenRn_ #-} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 276cf5a..e9a287d 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -35,6 +35,9 @@ import Name import Pretty import PprStyle ( PprStyle(..) ) import Util ( panic, pprTrace, assertPanic ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} @@ -47,8 +50,11 @@ import Util ( panic, pprTrace, assertPanic ) \begin{code} getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo])) + -> RnMG (Maybe (ExportEnv, RnEnv, NameSet)) -- Nothing <=> no need to recompile + -- The NameSet is the set of names that are + -- either locally defined, + -- or explicitly imported getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) = fixRn (\ ~(rec_exp_fn, _) -> @@ -56,11 +62,11 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails) -> + importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_avails) -> -- PROCESS IMPORT DECLS - mapAndUnzipRn importsFromImportDecl all_imports - `thenRn` \ (imp_rn_envs, imp_avails_s) -> + mapAndUnzip3Rn importsFromImportDecl all_imports + `thenRn` \ (imp_rn_envs, imp_avails_s, explicit_imports_s) -> -- CHECK FOR EARLY EXIT checkEarlyExit this_mod `thenRn` \ early_exit -> @@ -76,7 +82,10 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) let all_avails :: ModuleAvails all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s - local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod) + + explicit_names :: NameSet -- locally defined or explicitly imported + explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s) + add_on avails names = foldr (unionNameSets . mkNameSet . availNames) names avails in -- PROCESS EXPORT LISTS @@ -86,7 +95,7 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc) -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE mapRn (recordSlurp Nothing) local_avails `thenRn_` - returnRn (export_fn, Just (export_env, rn_env, local_avails)) + returnRn (export_fn, Just (export_env, rn_env, explicit_names)) ) `thenRn` \ (_, result) -> returnRn result where @@ -132,12 +141,12 @@ checkEarlyExit mod \begin{code} importsFromImportDecl :: RdrNameImportDecl - -> RnMG (RnEnv, ModuleAvails) + -> RnMG (RnEnv, ModuleAvails, [AvailInfo]) importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) = pushSrcLocRn loc $ getInterfaceExports mod `thenRn` \ (avails, fixities) -> - filterImports mod import_spec avails `thenRn` \ filtered_avails -> + filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> let filtered_avails' = map set_avail_prov filtered_avails fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ] @@ -147,6 +156,9 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc) (not qual_only) -- Maybe want unqualified names as_mod (ExportEnv filtered_avails' fixities') + hides + `thenRn` \ (rn_env, mod_avails) -> + returnRn (rn_env, mod_avails, explicits) where set_avail_prov NotAvailable = NotAvailable set_avail_prov (Avail n) = Avail (set_name_prov n) @@ -165,6 +177,9 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _) True -- Want unqualified names Nothing -- No "as M" part (ExportEnv avails fixities) + [] -- Hide nothing + `thenRn` \ (rn_env, mod_avails) -> + returnRn (rn_env, mod_avails, avails) where newLocalName rdr_name loc = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc @@ -197,44 +212,45 @@ available, and filters it through the import spec (if any). filterImports :: Module -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin -> [AvailInfo] -- What's available - -> RnMG [AvailInfo] -- What's actually imported - -- Complains if import spec mentions things the - -- module doesn't export + -> RnMG ([AvailInfo], -- What's actually imported + [AvailInfo], -- What's to be hidden (the unqualified version, that is) + [AvailInfo]) -- What was imported explicitly + + -- Complains if import spec mentions things that the module doesn't export filterImports mod Nothing imports - = returnRn imports + = returnRn (imports, [], []) filterImports mod (Just (want_hiding, import_items)) avails - = foldlRn (filter_item want_hiding) initial_avails import_items - where - initial_avails | want_hiding = avails - | otherwise = [] + = mapRn check_item import_items `thenRn` \ item_avails -> + if want_hiding + then + returnRn (avails, item_avails, []) -- All imported; item_avails to be hidden + else + returnRn (item_avails, [], item_avails) -- Just item_avails imported; nothing to be hidden + where import_fm :: FiniteMap OccName AvailInfo import_fm = listToFM [ (nameOccName name, avail) | avail <- avails, name <- availEntityNames avail] - filter_item want_hiding avails_so_far item@(IEModuleContents _) + check_item item@(IEModuleContents _) = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn avails_so_far + returnRn NotAvailable - filter_item want_hiding avails_so_far item + check_item item | not (maybeToBool maybe_in_import_avails) || (case filtered_avail of { NotAvailable -> True; other -> False }) = addErrRn (badImportItemErr mod item) `thenRn_` - returnRn avails_so_far + returnRn NotAvailable - | want_hiding = returnRn (foldr hide_it [] avails_so_far) - | otherwise = returnRn (filtered_avail : avails_so_far) -- Explicit import list + | otherwise = returnRn filtered_avail where maybe_in_import_avails = lookupFM import_fm (ieOcc item) Just avail = maybe_in_import_avails filtered_avail = filterAvail item avail - hide_it avail avails = case hideAvail item avail of - NotAvailable -> avails - avail' -> avail' : avails \end{code} @@ -256,48 +272,54 @@ qualifyImports :: Module -- Imported module -> Bool -- True <=> want unqualified import -> Maybe Module -- Optional "as M" part -> ExportEnv -- What's imported + -> [AvailInfo] -- What's to be hidden -> RnMG (RnEnv, ModuleAvails) -qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) - = -- Make the qualified-name environments, checking of course for clashes - foldlRn add_name emptyNameEnv avails `thenRn` \ name_env -> - foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env -> - returnRn (RnEnv name_env fixity_env, mod_avail_env) - where - show_it (rdr, (fix,prov)) = ppSep [ppLbrack, ppr PprDebug rdr, ppr PprDebug fix, pprProvenance PprDebug prov, ppRbrack] +qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) hides + = let + -- Make the name environment. Since we're talking about a single import module + -- there can't be name clashes, so we don't need to be in the monad + name_env1 = foldl add_avail emptyNameEnv avails + -- Delete things that are hidden + name_env2 = foldl del_avail name_env1 hides + + -- Create the fixity env + fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities + + -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1) + mod_avail_env | unqual_imp = unitFM qual_mod avails + | otherwise = emptyFM + in + returnRn (RnEnv name_env2 fixity_env, mod_avail_env) + where qual_mod = case as_mod of Nothing -> this_mod Just another_name -> another_name - mod_avail_env = unitFM qual_mod avails - - add_name name_env avail = foldlRn add_one name_env (availNames avail) - - add_one :: NameEnv -> Name -> RnMG NameEnv - add_one env name = add_to_env addOneToNameEnvRn env occ_name name - where - occ_name = nameOccName name - - add_to_env add_fn env occ thing | qual_imp && unqual_imp = both - | qual_imp = qual_only - | unqual_imp = unqual_only - where - unqual_only = add_fn env (Unqual occ) thing - qual_only = add_fn env (Qual qual_mod occ) thing - both = unqual_only `thenRn` \ env' -> - add_fn env' (Qual qual_mod occ) thing + add_avail env avail = foldl add_name env (availNames avail) + add_name env name = env2 + where + env1 | qual_imp = addOneToNameEnv env (Qual qual_mod occ) name + | otherwise = env + env2 | unqual_imp = addOneToNameEnv env1 (Unqual occ) name + | otherwise = env1 + occ = nameOccName name + + del_avail env avail = foldl delOneFromNameEnv env rdr_names + where + rdr_names = map (Unqual . nameOccName) (availNames avail) - add_fixity name_env fixity_env (occ_name, (fixity, provenance)) - | maybeToBool (lookupFM name_env rdr_name) -- It's imported - = add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance) - | otherwise -- It ain't imported - = returnRn fixity_env - where - -- rdr_name is a name by which the thing is guaranteed to be known, - -- *if it is imported at all* - rdr_name | qual_imp = Qual qual_mod occ_name - | otherwise = Unqual occ_name + add_fixity name_env fix_env (occ_name, (fixity, provenance)) + = add qual $ add unqual $ fix_env + where + qual = Qual qual_mod occ_name + unqual = Unqual occ_name + + add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name) + = addOneToFixityEnv fix_env rdr_name (fixity,provenance) + | otherwise + = fix_env \end{code} unQualify adds an Unqual binding for every existing Qual binding. @@ -489,21 +511,21 @@ mk_export_fn avails \begin{code} badImportItemErr mod ie sty - = ppSep [ppPStr SLIT("Module"), pprModule sty mod, ppPStr SLIT("does not export"), ppr sty ie] + = sep [ptext SLIT("Module"), pprModule sty mod, ptext SLIT("does not export"), ppr sty ie] modExportErr mod sty - = ppCat [ ppPStr SLIT("Unknown module in export list: module"), ppPStr mod] + = hsep [ ptext SLIT("Unknown module in export list: module"), ptext mod] exportItemErr export_item NotAvailable sty - = ppSep [ ppPStr SLIT("Export item not in scope:"), ppr sty export_item ] + = sep [ ptext SLIT("Export item not in scope:"), ppr sty export_item ] exportItemErr export_item avail sty - = ppHang (ppPStr SLIT("Export item not fully in scope:")) - 4 (ppAboves [ppCat [ppPStr SLIT("Wanted: "), ppr sty export_item], - ppCat [ppPStr SLIT("Available: "), ppr sty (ieOcc export_item), pprAvail sty avail]]) + = hang (ptext SLIT("Export item not fully in scope:")) + 4 (vcat [hsep [ptext SLIT("Wanted: "), ppr sty export_item], + hsep [ptext SLIT("Available: "), ppr sty (ieOcc export_item), pprAvail sty avail]]) availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty - = ppHang (ppCat [ppPStr SLIT("Conflicting exports for local name: "), ppr sty occ_name]) - 4 (ppAboves [ppr sty ie1, ppr sty ie2]) + = hang (hsep [ptext SLIT("Conflicting exports for local name: "), ppr sty occ_name]) + 4 (vcat [ppr sty ie1, ppr sty ie2]) \end{code} diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot new file mode 100644 index 0000000..7fec671 --- /dev/null +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -0,0 +1,8 @@ +_interface_ RnSource 1 +_exports_ +RnSource rnHsSigType; +_declarations_ +1 rnHsSigType _:_ _forall_ [a] => (PprStyle.PprStyle -> Pretty.Doc) + -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS a RnHsSyn.RenamedHsType ;; + diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 65edce3..63aa9a5 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -6,10 +6,11 @@ \begin{code} #include "HsVersions.h" -module RnSource ( rnDecl, rnHsType ) where +module RnSource ( rnDecl, rnHsType, rnHsSigType ) where IMP_Ubiq() IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking +IMPORT_1_3(List(partition)) import HsSyn import HsDecls ( HsIdInfo(..) ) @@ -22,7 +23,7 @@ import CmdLineOpts ( opt_IgnoreIfacePragmas ) import RnBinds ( rnTopBinds, rnMethodBinds ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, - lookupOptionalOccRn, newSysName, newDfunName, + lookupOptionalOccRn, newSysName, newDfunName, checkDupOrQualNames, checkDupNames, listType_RDR, tupleType_RDR ) import RnMonad @@ -41,20 +42,20 @@ import SpecEnv ( SpecEnv ) import Lex ( isLexCon ) import CoreUnfold ( Unfolding(..), SimpleUnfolding ) import MagicUFs ( MagicUnfoldingFun ) -import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR ) +import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Outputable ( Outputable(..){-instances-} ) ---import PprStyle -- ToDo:rm +import PprStyle import Pretty import SrcLoc ( SrcLoc ) -- import TyCon ( TyCon{-instance NamedThing-} ) import Unique ( Unique ) import UniqSet ( SYN_IE(UniqSet) ) import UniqFM ( UniqFM, lookupUFM ) -import Util ( isIn, isn'tIn, thenCmp, removeDups, cmpPString, - panic, assertPanic{- , pprTrace ToDo:rm-} ) +import Util {- ( isIn, isn'tIn, thenCmp, removeDups, cmpPString, + panic, assertPanic{- , pprTrace ToDo:rm-} ) -} \end{code} rnDecl `renames' declarations. @@ -118,32 +119,28 @@ it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc)) +rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsRn "data declaration" tyvars $ \ tyvars' -> - rnContext context `thenRn` \ context' -> - mapRn rnConDecl condecls `thenRn` \ condecls' -> - rnDerivs derivings `thenRn` \ derivings' -> + lookupBndrRn tycon `thenRn` \ tycon' -> + bindTyVarsRn data_doc tyvars $ \ tyvars' -> + rnContext context `thenRn` \ context' -> + checkDupOrQualNames data_doc con_names `thenRn_` + mapRn rnConDecl condecls `thenRn` \ condecls' -> + rnDerivs derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) - -rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc)) - = pushSrcLocRn src_loc $ - lookupBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' -> - rnContext context `thenRn` \ context' -> - rnConDecl condecl `thenRn` \ condecl' -> - rnDerivs derivings `thenRn` \ derivings' -> - ASSERT(isNoDataPragmas pragmas) - returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)) + returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) + where + data_doc sty = text "the data type declaration for" <+> ppr sty tycon + con_names = map conDeclName condecls rnDecl (TyD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> - bindTyVarsRn "type declaration" tyvars $ \ tyvars' -> + bindTyVarsRn syn_doc tyvars $ \ tyvars' -> rnHsType ty `thenRn` \ ty' -> returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) + where + syn_doc sty = text "the declaration for type synonym" <+> ppr sty name \end{code} %********************************************************* @@ -159,25 +156,48 @@ original names, reporting any unknown names. \begin{code} rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) = pushSrcLocRn src_loc $ - bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] -> + bindTyVarsRn cls_doc [tyvar] $ \ [tyvar'] -> rnContext context `thenRn` \ context' -> lookupBndrRn cname `thenRn` \ cname' -> + + -- Check the signatures + checkDupOrQualNames sig_doc sig_names `thenRn_` mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' -> + + + -- Check the methods + checkDupOrQualNames meth_doc meth_names `thenRn_` rnMethodBinds mbinds `thenRn` \ mbinds' -> + + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + ASSERT(isNoClassPragmas pragmas) returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)) where + cls_doc sty = text "the declaration for class" <+> ppr sty cname + sig_doc sty = text "the signatures for class" <+> ppr sty cname + meth_doc sty = text "the default-methods for class" <+> ppr sty cname + + sig_names = [(op,locn) | ClassOpSig op _ _ locn <- sigs] + meth_names = bagToList (collectMonoBinders mbinds) + rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn) = pushSrcLocRn locn $ + lookupBndrRn op `thenRn` \ op_name -> + rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty -> + + -- Call up interface info for default method, if such info exists let dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) in - lookupBndrRn op `thenRn` \ op_name -> newSysName dm_occ Exported locn `thenRn` \ dm_name -> addOccurrenceName Optional dm_name `thenRn_` - -- Call up interface info for default method, if such info exists - rnHsType ty `thenRn` \ new_ty -> + + -- Checks..... let (ctxt, op_ty) = case new_ty of HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty) @@ -186,17 +206,16 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we -- don't care about that in - -- check that class tyvar appears in op_ty + -- Check that class tyvar appears in op_ty checkRn (clas_tyvar `elemNameSet` op_ty_fvs) (classTyVarNotInOpTyErr clas_tyvar sig) `thenRn_` - -- check that class tyvar *doesn't* appear in the sig's context + -- Check that class tyvar *doesn't* appear in the sig's context checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs)) (classTyVarInOpCtxtErr clas_tyvar sig) `thenRn_` --- ASSERT(isNoClassOpPragmas pragmas) returnRn (ClassOpSig op_name dm_name new_ty locn) \end{code} @@ -210,7 +229,12 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)) \begin{code} rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) = pushSrcLocRn src_loc $ - rnHsType inst_ty `thenRn` \ inst_ty' -> + rnHsSigType (\sty -> text "an instance decl") inst_ty `thenRn` \ inst_ty' -> + + + -- Rename the bindings + -- NB meth_names can be qualified! + checkDupNames meth_doc meth_names `thenRn_` rnMethodBinds mbinds `thenRn` \ mbinds' -> mapRn rn_uprag uprags `thenRn` \ new_uprags -> @@ -219,13 +243,17 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- The dfun is not optional, because we use its version number -- to identify the version of the instance declaration + -- The typechecker checks that all the bindings are for the right class. returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc)) where + meth_doc sty = text "the bindings in an instance declaration" + meth_names = bagToList (collectMonoBinders mbinds) + rn_uprag (SpecSig op ty using locn) = pushSrcLocRn src_loc $ - lookupBndrRn op `thenRn` \ op_name -> - rnHsType ty `thenRn` \ new_ty -> - rn_using using `thenRn` \ new_using -> + lookupBndrRn op `thenRn` \ op_name -> + rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty -> + rn_using using `thenRn` \ new_using -> returnRn (SpecSig op_name new_ty new_using locn) rn_uprag (InlineSig op locn) @@ -295,34 +323,38 @@ rnDerivs (Just ds) \end{code} \begin{code} -rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl +conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) +conDeclName (ConDecl n _ _ l) = (n,l) -rnConDecl (ConDecl name tys src_loc) - = pushSrcLocRn src_loc $ - checkConName name `thenRn_` - lookupBndrRn name `thenRn` \ new_name -> - mapRn rnBangTy tys `thenRn` \ new_tys -> - returnRn (ConDecl new_name new_tys src_loc) - -rnConDecl (ConOpDecl ty1 op ty2 src_loc) - = pushSrcLocRn src_loc $ - lookupBndrRn op `thenRn` \ new_op -> - rnBangTy ty1 `thenRn` \ new_ty1 -> +rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl +rnConDecl (ConDecl name cxt details locn) + = pushSrcLocRn locn $ + checkConName name `thenRn_` + lookupBndrRn name `thenRn` \ new_name -> + rnConDetails name locn details `thenRn` \ new_details -> + rnContext cxt `thenRn` \ new_context -> + returnRn (ConDecl new_name new_context new_details locn) + +rnConDetails con locn (VanillaCon tys) + = mapRn rnBangTy tys `thenRn` \ new_tys -> + returnRn (VanillaCon new_tys) + +rnConDetails con locn (InfixCon ty1 ty2) + = rnBangTy ty1 `thenRn` \ new_ty1 -> rnBangTy ty2 `thenRn` \ new_ty2 -> - returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc) + returnRn (InfixCon new_ty1 new_ty2) -rnConDecl (NewConDecl name ty src_loc) - = pushSrcLocRn src_loc $ - checkConName name `thenRn_` - lookupBndrRn name `thenRn` \ new_name -> - rnHsType ty `thenRn` \ new_ty -> - returnRn (NewConDecl new_name new_ty src_loc) +rnConDetails con locn (NewCon ty) + = rnHsType ty `thenRn` \ new_ty -> + returnRn (NewCon new_ty) -rnConDecl (RecConDecl name fields src_loc) - = pushSrcLocRn src_loc $ - lookupBndrRn name `thenRn` \ new_name -> - mapRn rnField fields `thenRn` \ new_fields -> - returnRn (RecConDecl new_name new_fields src_loc) +rnConDetails con locn (RecCon fields) + = checkDupOrQualNames fld_doc field_names `thenRn_` + mapRn rnField fields `thenRn` \ new_fields -> + returnRn (RecCon new_fields) + where + fld_doc sty = text "the fields of constructor" <> ppr sty con + field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] rnField (names, ty) = mapRn lookupBndrRn names `thenRn` \ new_names -> @@ -360,12 +392,11 @@ checkConName name %********************************************************* \begin{code} -rnHsType :: RdrNameHsType -> RnMS s RenamedHsType - -rnHsType (HsForAllTy tvs ctxt ty) - = rn_poly_help tvs ctxt ty +rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. -rnHsType full_ty@(HsPreForAllTy ctxt ty) +rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars) = getNameEnv `thenRn` \ name_env -> let mentioned_tyvars = extractHsTyVars full_ty @@ -373,6 +404,35 @@ rnHsType full_ty@(HsPreForAllTy ctxt ty) not_in_scope tv = case lookupFM name_env tv of Nothing -> True Just _ -> False + + non_foralld_constrained = [tv | (clas, ty) <- ctxt, + tv <- extractHsTyVars ty, + not (tv `elem` forall_tyvars) + ] + in +-- checkRn (null non_foralld_constrained) +-- (ctxtErr sig_doc non_foralld_constrained) `thenRn_` + + (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars -> + rnContext ctxt `thenRn` \ new_ctxt -> + rnHsType ty `thenRn` \ new_ty -> + returnRn (HsForAllTy new_tyvars new_ctxt new_ty) + ) + where + sig_doc sty = text "the type signature for" <+> doc_str sty + + +rnHsSigType doc_str other_ty = rnHsType other_ty + +rnHsType :: RdrNameHsType -> RnMS s RenamedHsType +rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kinded) + = rn_poly_help tvs ctxt ty + +rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type. + -- Universally quantify over tyvars in context + = getNameEnv `thenRn` \ name_env -> + let + forall_tyvars = foldr unionLists [] (map (extractHsTyVars . snd) ctxt) in rn_poly_help (map UserTyVar forall_tyvars) ctxt ty @@ -403,17 +463,17 @@ rnHsType (MonoDictTy clas ty) rnHsType ty `thenRn` \ ty' -> returnRn (MonoDictTy clas' ty') - rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars -> RdrNameContext -> RdrNameHsType -> RnMS s RenamedHsType - rn_poly_help tyvars ctxt ty - = bindTyVarsRn "type signature" tyvars $ \ new_tyvars -> + = bindTyVarsRn sig_doc tyvars $ \ new_tyvars -> rnContext ctxt `thenRn` \ new_ctxt -> rnHsType ty `thenRn` \ new_ty -> returnRn (HsForAllTy new_tyvars new_ctxt new_ty) + where + sig_doc sty = text "a nested for-all type" \end{code} @@ -424,18 +484,41 @@ rnContext ctxt = mapRn rn_ctxt ctxt `thenRn` \ result -> let (_, dup_asserts) = removeDups cmp_assert result + (alls, theta) = partition (\(c,_) -> c == allClass_NAME) result + non_tyvar_alls = [(c,t) | (c,t) <- alls, not (is_tyvar t)] in - -- If this isn't an error, then it ought to be: - mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_` - returnRn result + + -- Check for duplicate assertions + -- If this isn't an error, then it ought to be: + mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` + + -- Check for All constraining a non-type-variable + mapRn (addWarnRn . allOfNonTyVar) non_tyvar_alls `thenRn_` + + -- Done. Return a theta omitting all the "All" constraints. + -- They have done done their work by ensuring that we universally + -- quantify over their tyvar. + returnRn theta where rn_ctxt (clas, ty) - = lookupOccRn clas `thenRn` \ clas_name -> + = -- Mini hack here. If the class is our pseudo-class "All", + -- then we don't want to record it as an occurrence, otherwise + -- we try to slurp it in later and it doesn't really exist at all. + -- Easiest thing is simply not to put it in the occurrence set. + lookupBndrRn clas `thenRn` \ clas_name -> + (if clas_name /= allClass_NAME then + addOccurrenceName Compulsory clas_name + else + returnRn clas_name + ) `thenRn_` rnHsType ty `thenRn` \ ty' -> returnRn (clas_name, ty') cmp_assert (c1,ty1) (c2,ty2) = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2) + + is_tyvar (MonoTyVar _) = True + is_tyvar other = False \end{code} @@ -604,74 +687,33 @@ rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) \begin{code} derivingNonStdClassErr clas sty - = ppCat [ppPStr SLIT("non-standard class in deriving:"), ppr sty clas] + = hsep [ptext SLIT("non-standard class in deriving:"), ppr sty clas] classTyVarNotInOpTyErr clas_tyvar sig sty - = ppHang (ppBesides [ppPStr SLIT("Class type variable `"), + = hang (hcat [ptext SLIT("Class type variable `"), ppr sty clas_tyvar, - ppPStr SLIT("' does not appear in method signature:")]) + ptext SLIT("' does not appear in method signature:")]) 4 (ppr sty sig) classTyVarInOpCtxtErr clas_tyvar sig sty - = ppHang (ppBesides [ ppPStr SLIT("Class type variable `"), ppr sty clas_tyvar, - ppPStr SLIT("' present in method's local overloading context:")]) + = hang (hcat [ ptext SLIT("Class type variable `"), ppr sty clas_tyvar, + ptext SLIT("' present in method's local overloading context:")]) 4 (ppr sty sig) dupClassAssertWarn ctxt dups sty - = ppHang (ppBesides [ppPStr SLIT("Duplicate class assertion `"), + = hang (hcat [ptext SLIT("Duplicate class assertion `"), ppr sty dups, - ppPStr SLIT("' in context:")]) + ptext SLIT("' in context:")]) 4 (ppr sty ctxt) badDataCon name sty - = ppCat [ppPStr SLIT("Illegal data constructor name:"), ppr sty name] -\end{code} - + = hsep [ptext SLIT("Illegal data constructor name:"), ppr sty name] +allOfNonTyVar ty sty + = hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty] - - -=================== OLD STUFF ====================== - -%********************************************************* -%* * -\subsection{SPECIALIZE data pragmas} -%* * -%********************************************************* - -\begin{pseudocode} -rnSpecDataSig :: RdrNameSpecDataSig - -> RnMS s RenamedSpecDataSig - -rnSpecDataSig (SpecDataSig tycon ty src_loc) - = pushSrcLocRn src_loc $ - let - tyvars = filter extractHsTyNames ty - in - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> - lookupOccRn tycon `thenRn` \ tycon' -> - rnHsType tv_env ty `thenRn` \ ty' -> - returnRn (SpecDataSig tycon' ty' src_loc) - -\end{pseudocode} - -%********************************************************* -%* * -\subsection{@SPECIALIZE instance@ user-pragmas} -%* * -%********************************************************* - -\begin{pseudocode} -rnSpecInstSig :: RdrNameSpecInstSig - -> RnMS s RenamedSpecInstSig - -rnSpecInstSig (SpecInstSig clas ty src_loc) - = pushSrcLocRn src_loc $ - let - tyvars = extractHsTyNames is_tyvar_name ty - in - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) -> - lookupOccRn clas `thenRn` \ new_clas -> - rnHsType tv_env ty `thenRn` \ new_ty -> - returnRn (SpecInstSig new_clas new_ty src_loc) -\end{pseudocode} +ctxtErr doc tyvars sty + = hsep [ptext SLIT("Context constrains type variable(s)"), + hsep (punctuate comma (map (ppr sty) tyvars))] + $$ nest 4 (ptext SLIT("in") <+> doc sty) +\end{code} -- 1.7.10.4