[project @ 1997-05-19 00:12:10 by sof]

2.04 changes

ghc/compiler/absCSyn/AbsCLoop.hs

+module AbsCLoop 
+       (
+        module MachMisc,
+	module CLabel,
+	module ClosureInfo,
+	module CgRetConv
+       )where
+
+import MachMisc
+import CLabel
+import ClosureInfo
+import CgRetConv

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

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}
 
 

ghc/compiler/absCSyn/CLabel.hi-boot

+_interface_ CLabel 1
+_exports_
+CLabel CLabel;
+_declarations_
+1 data CLabel;

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}

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<x>	ZP<x>
 
 \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

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}
 
 %************************************************************************

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}
 
 

ghc/compiler/basicTypes/FieldLabel.hi-boot

+_interface_ FieldLabel 1
+_exports_
+FieldLabel FieldLabel;
+_declarations_
+1 data FieldLabel;

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
 

ghc/compiler/basicTypes/Id.hi-boot

 _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) ;;
 

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) )
+			) -}