[project @ 2001-11-08 12:56:00 by simonmar]

Updates to the native code generator following the changes to fix the
large block allocation bug, and changes to use the new
function-address cache in the register table to reduce code size.

Also: I changed the pretty-printing machinery for assembly code to use
Pretty rather than Outputable, since we don't make use of the styles
and it should improve performance.  Perhaps the same should be done
for abstract C.

12 files changed, 168 insertions, 151 deletions

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index 9aa589b437..2a6a8277ad 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: AbsCSyn.lhs,v 1.38 2001/09/26 15:11:50 simonpj Exp $
+% $Id: AbsCSyn.lhs,v 1.39 2001/11/08 12:56:01 simonmar Exp $
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -494,6 +494,7 @@ data MagicId
 
   | CurrentTSO		-- pointer to current thread's TSO
   | CurrentNursery	-- pointer to allocation area
+  | HpAlloc		-- allocation count for heap check failure
 
 
 node 	= VanillaReg PtrRep     (_ILIT 1) -- A convenient alias for Node
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index c8712f5f17..4da5c5773a 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CLabel.lhs,v 1.47 2001/09/04 18:29:20 ken Exp $
+% $Id: CLabel.lhs,v 1.48 2001/11/08 12:56:01 simonmar Exp $
 %
 \section[CLabel]{@CLabel@: Information to make C Labels}
 
@@ -70,9 +70,6 @@ module CLabel (
 	CLabelType(..), labelType, labelDynamic,
 
 	pprCLabel
-#if ! OMIT_NATIVE_CODEGEN
-	, pprCLabel_asm
-#endif
     ) where
 
 
@@ -431,11 +428,6 @@ internal names. <type> is one of the following:
 	 ccs			Cost centre stack
 
 \begin{code}
--- specialised for PprAsm: saves lots of arg passing in NCG
-#if ! OMIT_NATIVE_CODEGEN
-pprCLabel_asm = pprCLabel
-#endif
-
 pprCLabel :: CLabel -> SDoc
 
 #if ! OMIT_NATIVE_CODEGEN
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 95401cef15..395341040a 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -34,6 +34,7 @@ import Module		( Module )
 import CmdLineOpts
 import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
+import Pretty		( Mode(..), printDoc )
 import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
 
 import IOExts
@@ -134,8 +135,9 @@ outputAsm dflags filenm flat_absC
        let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen" 
 				        nativeCodeGen flat_absC ncg_uniqs
        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
-       dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
-       _scc_ "OutputAsm" doOutput filenm ( \f -> printForAsm f ncg_output_d)
+       dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
+       _scc_ "OutputAsm" doOutput filenm $
+	   \f -> printDoc LeftMode f ncg_output_d
   where
 
 #else /* OMIT_NATIVE_CODEGEN */
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index e98648b282..22b95a57d5 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -32,7 +32,7 @@ import UniqSupply	( returnUs, thenUs, initUs,
 			  lazyMapUs )
 import MachMisc		( IF_ARCH_i386(i386_insert_ffrees,) )
 
-import OrdList		( concatOL )
+import qualified Pretty
 import Outputable
 
 \end{code}
@@ -85,7 +85,7 @@ The machine-dependent bits break down as follows:
 So, here we go:
 
 \begin{code}
-nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc)
+nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, Pretty.Doc)
 nativeCodeGen absC us
    = let absCstmts         = mkAbsCStmtList absC
          (sdoc_pairs, us1) = initUs us (lazyMapUs absCtoNat absCstmts)
@@ -102,22 +102,22 @@ nativeCodeGen absC us
                                           $$ char ' ') 
                                           sds)
 #        else
-         my_vcat sds = vcat sds
+         my_vcat sds = Pretty.vcat sds
          my_trace m x = x
 #        endif
-     in  
-         my_trace "nativeGen: begin" 
+     in
+         my_trace "nativeGen: begin"
                   (stix_sdoc, insn_sdoc)
 
 
-absCtoNat :: AbstractC -> UniqSM (SDoc, SDoc)
+absCtoNat :: AbstractC -> UniqSM (SDoc, Pretty.Doc)
 absCtoNat absC
    = _scc_ "genCodeAbstractC" genCodeAbstractC absC        `thenUs` \ stixRaw ->
      _scc_ "genericOpt"       genericOpt stixRaw           `bind`   \ stixOpt ->
      _scc_ "genMachCode"      genMachCode stixOpt          `thenUs` \ pre_regalloc ->
      _scc_ "regAlloc"         regAlloc pre_regalloc        `bind`   \ almost_final ->
      _scc_ "x86fp_kludge"     x86fp_kludge almost_final    `bind`   \ final_mach_code ->
-     _scc_ "vcat"     vcat (map pprInstr final_mach_code)  `bind`   \ final_sdoc ->
+     _scc_ "vcat"     Pretty.vcat (map pprInstr final_mach_code)  `bind`   \ final_sdoc ->
      _scc_ "pprStixTrees"    pprStixTrees stixOpt          `bind`   \ stix_sdoc ->
      returnUs (stix_sdoc, final_sdoc)
      where
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 5922411801..bd2b1115fa 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -71,7 +71,7 @@ runRegAllocate regs find_reserve_regs instrs
               $$
               (text "code = ")
               $$
-              (vcat (map pprInstr flatInstrs))
+              (vcat (map (docToSDoc.pprInstr) flatInstrs))
             )
     tryGeneral (resv:resvs)
        = case generalAlloc resv of
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 341c889aea..b2a4e8239f 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -36,11 +36,12 @@ import Stix		( getNatLabelNCG, StixTree(..),
                           getDeltaNat, setDeltaNat,
                           ncgPrimopMoan
 			)
-import Outputable
+import Pretty
+import Outputable	( panic, pprPanic )
+import qualified Outputable
 import CmdLineOpts	( opt_Static )
 
 infixr 3 `bind`
-
 \end{code}
 
 @InstrBlock@s are the insn sequences generated by the insn selectors.
@@ -49,11 +50,9 @@ left-to-right traversal (pre-order?) yields the insns in the correct
 order.
 
 \begin{code}
-
 type InstrBlock = OrdList Instr
 
 x `bind` f = f x
-
 \end{code}
 
 Code extractor for an entire stix tree---stix statement level.
@@ -186,6 +185,9 @@ stmtToInstrs stmt = case stmt of
     StString str
       -> returnNat (unitOL (ASCII True (_UNPK_ str)))
 
+#ifdef DEBUG
+    other -> pprPanic "stmtToInstrs" (pprStixTree other)
+#endif
 
 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
 -- as labelDynamic.  stmt2Instrs calls derefDLL selectively, because
@@ -246,7 +248,7 @@ mangleIndexTree (StIndex pk base off)
                    4 -> 2
                    8 -> 3
                    other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
-                                     (int other)
+                                     (Outputable.int other)
 \end{code}
 
 \begin{code}
@@ -286,17 +288,17 @@ registerCode (Fixed _ _ code) reg = code
 registerCode (Any _ code) reg = code reg
 
 registerCodeF (Fixed _ _ code) = code
-registerCodeF (Any _ _)        = pprPanic "registerCodeF" empty
+registerCodeF (Any _ _)        = panic "registerCodeF"
 
 registerCodeA (Any _ code)  = code
-registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
+registerCodeA (Fixed _ _ _) = panic "registerCodeA"
 
 registerName :: Register -> Reg -> Reg
 registerName (Fixed _ reg _) _ = reg
 registerName (Any _ _)   reg   = reg
 
 registerNameF (Fixed _ reg _) = reg
-registerNameF (Any _ _)       = pprPanic "registerNameF" empty
+registerNameF (Any _ _)       = panic "registerNameF"
 
 registerRep :: Register -> PrimRep
 registerRep (Fixed pk _ _) = pk
@@ -1501,19 +1503,16 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas"
 
 -- memory vs immediate
 condIntCode cond (StInd pk x) y
-  | maybeToBool imm
+  | Just i <- maybeImm y
   = getAmode x			`thenNat` \ amode ->
     let
     	code1 = amodeCode amode
     	x__2  = amodeAddr amode
         sz    = primRepToSize pk
     	code__2 = code1 `snocOL`
-    	    	  CMP sz (OpImm imm__2) (OpAddr x__2)
+    	    	  CMP sz (OpImm i) (OpAddr x__2)
     in
     returnNat (CondCode False cond code__2)
-  where
-    imm    = maybeImm y
-    imm__2 = case imm of Just x -> x
 
 -- anything vs zero
 condIntCode cond x (StInt 0)
@@ -1529,19 +1528,16 @@ condIntCode cond x (StInt 0)
 
 -- anything vs immediate
 condIntCode cond x y
-  | maybeToBool imm
+  | Just i <- maybeImm y
   = getRegister x		`thenNat` \ register1 ->
     getNewRegNCG IntRep		`thenNat` \ tmp1 ->
     let
 	code1 = registerCode register1 tmp1
 	src1  = registerName register1 tmp1
 	code__2 = code1 `snocOL`
-                  CMP L (OpImm imm__2) (OpReg src1)
+                  CMP L (OpImm i) (OpReg src1)
     in
     returnNat (CondCode False cond code__2)
-  where
-    imm    = maybeImm y
-    imm__2 = case imm of Just x -> x
 
 -- memory vs anything
 condIntCode cond (StInd pk x) y
@@ -1809,11 +1805,8 @@ assignIntCode pk (StInd _ dst) src
 	-> NatM (InstrBlock,Operand)	-- code, operator
 
     get_op_RI op
-      | maybeToBool imm
-      = returnNat (nilOL, OpImm imm_op)
-      where
-	imm    = maybeImm op
-	imm_op = case imm of Just x -> x
+      | Just x <- maybeImm op
+      = returnNat (nilOL, OpImm x)
 
     get_op_RI op
       = getRegister op			`thenNat` \ register ->
@@ -1848,7 +1841,7 @@ assignIntCode pk dst (StInd pks src)
               = c_addr `snocOL`
                 opc (OpAddr am_addr) (OpReg r_dst)
               | otherwise
-              = pprPanic "assignIntCode(x86): bad dst(2)" empty
+              = panic "assignIntCode(x86): bad dst(2)"
     in
     returnNat code
 
@@ -1867,7 +1860,7 @@ assignIntCode pk dst src
              = c_src `snocOL` 
                MOV L (OpReg r_src) (OpReg r_dst)
              | otherwise
-             = pprPanic "assignIntCode(x86): bad dst(3)" empty
+             = panic "assignIntCode(x86): bad dst(3)"
     in
     returnNat code
 
@@ -1945,7 +1938,7 @@ assignFltCode pk dst src
 -- dst is memory
 assignFltCode pk (StInd pk_dst addr) src
    | pk /= pk_dst
-   = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
+   = panic "assignFltCode(x86): src/ind sz mismatch"
    | otherwise
    = getRegister src      `thenNat`  \ reg_src  ->
      getRegister addr     `thenNat`  \ reg_addr ->
@@ -1984,8 +1977,7 @@ assignFltCode pk dst src
                then c_src `snocOL` GMOV r_src r_dst
                else c_src
              | otherwise
-             = pprPanic "assignFltCode(x86): lhs is not mem or reg" 
-                        empty
+             = panic "assignFltCode(x86): lhs is not mem or reg" 
     in
     returnNat code
 
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 904b612a2a..0dce2fe99a 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -32,6 +32,7 @@ module MachRegs (
 	saveLoc,
 	spRel,
 	stgReg,
+	regTableEntry,
 	strImmLit
 
 #if alpha_TARGET_ARCH
@@ -62,7 +63,9 @@ import PrimRep		( PrimRep(..), isFloatingRep )
 import Stix		( StixTree(..), StixReg(..),
                           getUniqueNat, returnNat, thenNat, NatM )
 import Unique		( mkPseudoUnique2, Uniquable(..), Unique )
-import Outputable
+import Pretty
+import Outputable	( Outputable(..), pprPanic, panic )
+import qualified Outputable
 import FastTypes
 \end{code}
 
@@ -73,9 +76,9 @@ data Imm
   = ImmInt	Int
   | ImmInteger	Integer	    -- Sigh.
   | ImmCLbl	CLabel	    -- AbstractC Label (with baggage)
-  | ImmLab	Bool SDoc    -- Simple string label (underscore-able)
+  | ImmLab	Bool Doc    -- Simple string label (underscore-able)
                              -- Bool==True ==> in a different DLL
-  | ImmLit	SDoc    -- Simple string
+  | ImmLit	Doc    -- Simple string
   | ImmIndex    CLabel Int
   | ImmFloat	Rational
   | ImmDouble	Rational
@@ -180,30 +183,30 @@ data RegLoc = Save StixTree | Always StixTree
 Trees for register save locations:
 \begin{code}
 saveLoc :: MagicId -> StixTree
-
 saveLoc reg = case (stgReg reg) of {Always loc -> loc; Save loc -> loc}
 \end{code}
 
 \begin{code}
 stgReg :: MagicId -> RegLoc
-
+stgReg BaseReg
+ = case magicIdRegMaybe BaseReg of
+	Nothing -> Always (StCLbl mkMainRegTableLabel)
+	Just _  -> Save   (StCLbl mkMainRegTableLabel)
 stgReg x
-  = case (magicIdRegMaybe x) of
-	Just _  -> Save   nonReg
-	Nothing -> Always nonReg
+  = case magicIdRegMaybe x of
+	Just _  -> Save   stix
+	Nothing -> Always stix
   where
-    offset = baseRegOffset x
+    stix   = regTableEntry (magicIdPrimRep x) (baseRegOffset x)
 
+regTableEntry :: PrimRep -> Int -> StixTree
+regTableEntry rep offset 
+  = StInd rep (StPrim IntAddOp 
+		   [baseLoc, StInt (toInteger (offset*BYTES_PER_WORD))])
+  where
     baseLoc = case (magicIdRegMaybe BaseReg) of
       Just _  -> StReg (StixMagicId BaseReg)
       Nothing -> StCLbl mkMainRegTableLabel
-
-    nonReg = case x of
-      BaseReg -> StCLbl mkMainRegTableLabel
-
-      _ -> StInd (magicIdPrimRep x)
-		 (StPrim IntAddOp [baseLoc,
-			StInt (toInteger (offset*BYTES_PER_WORD))])
 \end{code}
 
 % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -328,7 +331,7 @@ instance Show Reg where
     showsPrec _ (VirtualRegD u) = showString "%vD_"  . shows u
 
 instance Outputable Reg where
-    ppr r = text (show r)
+    ppr r = Outputable.text (show r)
 
 instance Uniquable Reg where
     getUnique (RealReg i)     = mkPseudoUnique2 i
@@ -630,6 +633,7 @@ baseRegOffset Hp		     = OFFSET_Hp
 baseRegOffset HpLim		     = OFFSET_HpLim
 baseRegOffset CurrentTSO	     = OFFSET_CurrentTSO
 baseRegOffset CurrentNursery	     = OFFSET_CurrentNursery
+baseRegOffset HpAlloc		     = OFFSET_HpAlloc
 #ifdef NCG_DEBUG
 baseRegOffset BaseReg		     = panic "baseRegOffset:BaseReg"
 baseRegOffset CurCostCentre	     = panic "baseRegOffset:CurCostCentre"
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index ab1e3d99e7..273a679da2 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -17,14 +17,21 @@ module PprMach ( pprInstr, pprSize, pprUserReg ) where
 import MachRegs		-- may differ per-platform
 import MachMisc
 
-import CLabel		( pprCLabel_asm, externallyVisibleCLabel, labelDynamic )
+import CLabel		( pprCLabel, externallyVisibleCLabel, labelDynamic )
 import Stix		( CodeSegment(..) )
-import Outputable
+import Unique		( pprUnique )
+import Panic		( panic )
+import Pretty
+import qualified Outputable
 
 import ST
 import MutableArray
 import Char		( chr, ord )
 import Maybe		( isJust )
+
+asmSDoc d = Outputable.withPprStyleDoc (
+	      Outputable.mkCodeStyle Outputable.AsmStyle) d
+pprCLabel_asm l = asmSDoc (pprCLabel l)
 \end{code}
 
 %************************************************************************
@@ -36,20 +43,19 @@ import Maybe		( isJust )
 For x86, the way we print a register name depends
 on which bit of it we care about.  Yurgh.
 \begin{code}
-pprUserReg :: Reg -> SDoc
+pprUserReg :: Reg -> Doc
 pprUserReg = pprReg IF_ARCH_i386(L,)
 
-
-pprReg :: IF_ARCH_i386(Size ->,) Reg -> SDoc
+pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc
 
 pprReg IF_ARCH_i386(s,) r
   = case r of
       RealReg i      -> ppr_reg_no IF_ARCH_i386(s,) i
-      VirtualRegI u  -> text "%vI_" <> ppr u
-      VirtualRegF u  -> text "%vF_" <> ppr u      
+      VirtualRegI u  -> text "%vI_" <> asmSDoc (pprUnique u)
+      VirtualRegF u  -> text "%vF_" <> asmSDoc (pprUnique u)
   where
 #if alpha_TARGET_ARCH
-    ppr_reg_no :: Int -> SDoc
+    ppr_reg_no :: Int -> Doc
     ppr_reg_no i = ptext
       (case i of {
 	 0 -> SLIT("$0");    1 -> SLIT("$1");
@@ -88,7 +94,7 @@ pprReg IF_ARCH_i386(s,) r
       })
 #endif
 #if i386_TARGET_ARCH
-    ppr_reg_no :: Size -> Int -> SDoc
+    ppr_reg_no :: Size -> Int -> Doc
     ppr_reg_no B  = ppr_reg_byte
     ppr_reg_no Bu = ppr_reg_byte
     ppr_reg_no W  = ppr_reg_word
@@ -124,7 +130,7 @@ pprReg IF_ARCH_i386(s,) r
       })
 #endif
 #if sparc_TARGET_ARCH
-    ppr_reg_no :: Int -> SDoc
+    ppr_reg_no :: Int -> Doc
     ppr_reg_no i = ptext
       (case i of {
 	 0 -> SLIT("%g0");   1 -> SLIT("%g1");
@@ -171,7 +177,7 @@ pprReg IF_ARCH_i386(s,) r
 %************************************************************************
 
 \begin{code}
-pprSize :: Size -> SDoc
+pprSize :: Size -> Doc
 
 pprSize x = ptext (case x of
 #if alpha_TARGET_ARCH
@@ -205,7 +211,7 @@ pprSize x = ptext (case x of
 	F   -> SLIT("")
 	DF  -> SLIT("d")
     )
-pprStSize :: Size -> SDoc
+pprStSize :: Size -> Doc
 pprStSize x = ptext (case x of
 	B   -> SLIT("b")
 	Bu  -> SLIT("b")
@@ -223,7 +229,7 @@ pprStSize x = ptext (case x of
 %************************************************************************
 
 \begin{code}
-pprCond :: Cond -> SDoc
+pprCond :: Cond -> Doc
 
 pprCond c = ptext (case c of {
 #if alpha_TARGET_ARCH
@@ -265,7 +271,7 @@ pprCond c = ptext (case c of {
 %************************************************************************
 
 \begin{code}
-pprImm :: Imm -> SDoc
+pprImm :: Imm -> Doc
 
 pprImm (ImmInt i)     = int i
 pprImm (ImmInteger i) = integer i
@@ -299,7 +305,7 @@ pprImm (HI i)
 %************************************************************************
 
 \begin{code}
-pprAddr :: MachRegsAddr -> SDoc
+pprAddr :: MachRegsAddr -> Doc
 
 #if alpha_TARGET_ARCH
 pprAddr (AddrReg r) = parens (pprReg r)
@@ -372,7 +378,7 @@ pprAddr (AddrRegImm r1 imm)
 %************************************************************************
 
 \begin{code}
-pprInstr :: Instr -> SDoc
+pprInstr :: Instr -> Doc
 
 --pprInstr (COMMENT s) = empty -- nuke 'em
 pprInstr (COMMENT s)
@@ -428,10 +434,10 @@ pprInstr (ASCII False{-no backslash conversion-} str)
 pprInstr (ASCII True str)
   = vcat (map do1 (str ++ [chr 0]))
     where
-       do1 :: Char -> SDoc
+       do1 :: Char -> Doc
        do1 c = ptext SLIT("\t.byte\t0x") <> hshow (ord c)
 
-       hshow :: Int -> SDoc
+       hshow :: Int -> Doc
        hshow n | n >= 0 && n <= 255
                = char (tab !! (n `div` 16)) <> char (tab !! (n `mod` 16))
        tab = "0123456789ABCDEF"
@@ -852,12 +858,12 @@ pprInstr (FUNEND clab)
 
 Continue with Alpha-only printing bits and bobs:
 \begin{code}
-pprRI :: RI -> SDoc
+pprRI :: RI -> Doc
 
 pprRI (RIReg r) = pprReg r
 pprRI (RIImm r) = pprImm r
 
-pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> SDoc
+pprRegRIReg :: FAST_STRING -> Reg -> RI -> Reg -> Doc
 
 pprRegRIReg name reg1 ri reg2
   = hcat [
@@ -871,7 +877,7 @@ pprRegRIReg name reg1 ri reg2
 	pprReg reg2
     ]
 
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
 
 pprSizeRegRegReg name size reg1 reg2 reg3
   = hcat [
@@ -1140,7 +1146,7 @@ gregno (RealReg i) = i
 gregno other       = --pprPanic "gregno" (ppr other)
                      999   -- bogus; only needed for debug printing
 
-pprG :: Instr -> SDoc -> SDoc
+pprG :: Instr -> Doc -> Doc
 pprG fake actual
    = (char '#' <> pprGInstr fake) $$ actual
 
@@ -1176,16 +1182,16 @@ pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 d
 
 Continue with I386-only printing bits and bobs:
 \begin{code}
-pprDollImm :: Imm -> SDoc
+pprDollImm :: Imm -> Doc
 
 pprDollImm i =  ptext SLIT("$") <> pprImm i
 
-pprOperand :: Size -> Operand -> SDoc
+pprOperand :: Size -> Operand -> Doc
 pprOperand s (OpReg r)   = pprReg s r
 pprOperand s (OpImm i)   = pprDollImm i
 pprOperand s (OpAddr ea) = pprAddr ea
 
-pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> SDoc
+pprSizeImmOp :: FAST_STRING -> Size -> Imm -> Operand -> Doc
 pprSizeImmOp name size imm op1
   = hcat [
         char '\t',
@@ -1198,7 +1204,7 @@ pprSizeImmOp name size imm op1
 	pprOperand size op1
     ]
 	
-pprSizeOp :: FAST_STRING -> Size -> Operand -> SDoc
+pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
 pprSizeOp name size op1
   = hcat [
     	char '\t',
@@ -1208,7 +1214,7 @@ pprSizeOp name size op1
 	pprOperand size op1
     ]
 
-pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
+pprSizeOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
 pprSizeOpOp name size op1 op2
   = hcat [
     	char '\t',
@@ -1220,7 +1226,7 @@ pprSizeOpOp name size op1 op2
 	pprOperand size op2
     ]
 
-pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
+pprSizeByteOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
 pprSizeByteOpOp name size op1 op2
   = hcat [
     	char '\t',
@@ -1232,7 +1238,7 @@ pprSizeByteOpOp name size op1 op2
 	pprOperand size op2
     ]
 
-pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> SDoc
+pprSizeOpReg :: FAST_STRING -> Size -> Operand -> Reg -> Doc
 pprSizeOpReg name size op1 reg
   = hcat [
     	char '\t',
@@ -1244,7 +1250,7 @@ pprSizeOpReg name size op1 reg
 	pprReg size reg
     ]
 
-pprSizeReg :: FAST_STRING -> Size -> Reg -> SDoc
+pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc
 pprSizeReg name size reg1
   = hcat [
     	char '\t',
@@ -1254,7 +1260,7 @@ pprSizeReg name size reg1
 	pprReg size reg1
     ]
 
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
 pprSizeRegReg name size reg1 reg2
   = hcat [
     	char '\t',
@@ -1266,7 +1272,7 @@ pprSizeRegReg name size reg1 reg2
         pprReg size reg2
     ]
 
-pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> SDoc
+pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> Doc
 pprSizeSizeRegReg name size1 size2 reg1 reg2
   = hcat [
     	char '\t',
@@ -1279,7 +1285,7 @@ pprSizeSizeRegReg name size1 size2 reg1 reg2
         pprReg size2 reg2
     ]
 
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
 pprSizeRegRegReg name size reg1 reg2 reg3
   = hcat [
     	char '\t',
@@ -1293,7 +1299,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3
         pprReg size reg3
     ]
 
-pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
+pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc
 pprSizeAddr name size op
   = hcat [
     	char '\t',
@@ -1303,7 +1309,7 @@ pprSizeAddr name size op
 	pprAddr op
     ]
 
-pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> SDoc
+pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc
 pprSizeAddrReg name size op dst
   = hcat [
     	char '\t',
@@ -1315,7 +1321,7 @@ pprSizeAddrReg name size op dst
 	pprReg size dst
     ]
 
-pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> SDoc
+pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> Doc
 pprSizeRegAddr name size src op
   = hcat [
     	char '\t',
@@ -1327,7 +1333,7 @@ pprSizeRegAddr name size src op
 	pprAddr op
     ]
 
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
+pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
 pprOpOp name size op1 op2
   = hcat [
     	char '\t',
@@ -1337,7 +1343,7 @@ pprOpOp name size op1 op2
 	pprOperand size op2
     ]
 
-pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> SDoc
+pprSizeOpOpCoerce :: FAST_STRING -> Size -> Size -> Operand -> Operand -> Doc
 pprSizeOpOpCoerce name size1 size2 op1 op2
   = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space,
 	pprOperand size1 op1,
@@ -1345,7 +1351,7 @@ pprSizeOpOpCoerce name size1 size2 op1 op2
 	pprOperand size2 op2
     ]
 
-pprCondInstr :: FAST_STRING -> Cond -> SDoc -> SDoc
+pprCondInstr :: FAST_STRING -> Cond -> Doc -> Doc
 pprCondInstr name cond arg
   = hcat [ char '\t', ptext name, pprCond cond, space, arg]
 
@@ -1566,11 +1572,11 @@ pprInstr (CALL imm n _)
 
 Continue with SPARC-only printing bits and bobs:
 \begin{code}
-pprRI :: RI -> SDoc
+pprRI :: RI -> Doc
 pprRI (RIReg r) = pprReg r
 pprRI (RIImm r) = pprImm r
 
-pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Doc
 pprSizeRegReg name size reg1 reg2
   = hcat [
     	char '\t',
@@ -1583,7 +1589,7 @@ pprSizeRegReg name size reg1 reg2
 	pprReg reg2
     ]
 
-pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Doc
 pprSizeRegRegReg name size reg1 reg2 reg3
   = hcat [
     	char '\t',
@@ -1598,7 +1604,7 @@ pprSizeRegRegReg name size reg1 reg2 reg3
 	pprReg reg3
     ]
 
-pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> SDoc
+pprRegRIReg :: FAST_STRING -> Bool -> Reg -> RI -> Reg -> Doc
 pprRegRIReg name b reg1 ri reg2
   = hcat [
 	char '\t',
@@ -1611,7 +1617,7 @@ pprRegRIReg name b reg1 ri reg2
 	pprReg reg2
     ]
 
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> SDoc
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
 pprRIReg name b ri reg1
   = hcat [
 	char '\t',
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index cc7a491eb9..e8c27d1d13 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -10,7 +10,7 @@ module Stix (
 	DestInfo(..), hasDestInfo,
 
 	stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, 
-        stgHp, stgHpLim, stgTagReg, stgR9, stgR10, 
+        stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10, 
 	stgCurrentTSO, stgCurrentNursery,
 
 	fixedHS, arrWordsHS, arrPtrsHS,
@@ -241,6 +241,7 @@ stgSu 		    = StReg (StixMagicId Su)
 stgSpLim	    = StReg (StixMagicId SpLim)
 stgHp		    = StReg (StixMagicId Hp)
 stgHpLim	    = StReg (StixMagicId HpLim)
+stgHpAlloc	    = StReg (StixMagicId HpAlloc)
 stgCurrentTSO	    = StReg (StixMagicId CurrentTSO)
 stgCurrentNursery   = StReg (StixMagicId CurrentNursery)
 stgR9               = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 6f4a5d1510..d3888eda6e 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -207,13 +207,13 @@ ind_static_info	= StCLbl mkIndStaticInfoLabel
 ind_info  	= StCLbl mkIndInfoLabel
 upd_frame_info	= StCLbl mkUpdInfoLabel
 seq_frame_info	= StCLbl mkSeqInfoLabel
-stg_update_PAP  = StCLbl mkStgUpdatePAPLabel
--- Some common call trees
 
-updatePAP, stackOverflow :: StixTree
+stg_update_PAP  = regTableEntry CodePtrRep OFFSET_stgUpdatePAP
+
+-- Some common call trees
 
-updatePAP     = StJump NoDestInfo stg_update_PAP
-stackOverflow = StCall SLIT("StackOverflow") CCallConv VoidRep []
+updatePAP :: StixTree
+updatePAP = StJump NoDestInfo stg_update_PAP
 \end{code}
 
 -----------------------------------------------------------------------------
@@ -228,6 +228,7 @@ checkCode macro args assts
     let args_stix = map amodeToStix args
 	newHp wds = StIndex PtrRep stgHp wds
 	assign_hp wds = StAssign PtrRep stgHp (newHp wds)
+	hp_alloc wds = StAssign IntRep stgHpAlloc wds
 	test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
 	cjmp_hp = StCondJump ulbl_pass test_hp
 
@@ -258,12 +259,12 @@ checkCode macro args assts
 	HP_CHK_NP      -> 
 		let [words,ptrs] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_enter ptrs : join : xs))
+			    assts (hp_alloc words : gc_enter ptrs : join : xs))
 
 	HP_CHK_SEQ_NP  -> 
 		let [words,ptrs] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_seq ptrs : join : xs))
+			    assts (hp_alloc words : gc_seq ptrs : join : xs))
 
 	STK_CHK_NP     -> 
 		let [words,ptrs] = args_stix
@@ -275,12 +276,14 @@ checkCode macro args assts
 		in  (\xs -> cjmp_sp_fail sp_words : 
 			    assign_hp hp_words : cjmp_hp :
 			    fail :
-			    assts (gc_enter ptrs : join : xs))
+			    assts (hp_alloc hp_words : gc_enter ptrs
+				   : join : xs))
 
 	HP_CHK	       -> 
 		let [words,ret,r,ptrs] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp :
-			    assts (assign_ret r ret : gc_chk ptrs : join : xs))
+			    assts (hp_alloc words : assign_ret r ret
+				   : gc_chk ptrs : join : xs))
 
 	STK_CHK	       -> 
 		let [words,ret,r,ptrs] = args_stix
@@ -292,47 +295,49 @@ checkCode macro args assts
 		in  (\xs -> cjmp_sp_fail sp_words :
 			    assign_hp hp_words : cjmp_hp :
 			    fail :
-			    assts (assign_ret r ret : gc_chk ptrs : join : xs))
+			    assts (hp_alloc hp_words : assign_ret r ret
+				  : gc_chk ptrs : join : xs))
 
 	HP_CHK_NOREGS  -> 
 		let [words] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_noregs : join : xs))
+			    assts (hp_alloc words : gc_noregs : join : xs))
 
 	HP_CHK_UNPT_R1 -> 
 		let [words] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_unpt_r1 : join : xs))
+			    assts (hp_alloc words : gc_unpt_r1 : join : xs))
 
 	HP_CHK_UNBX_R1 -> 
 		let [words] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_unbx_r1 : join : xs))
+			    assts (hp_alloc words : gc_unbx_r1 : join : xs))
 
 	HP_CHK_F1      -> 
 		let [words] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_f1 : join : xs))
+			    assts (hp_alloc words : gc_f1 : join : xs))
 
 	HP_CHK_D1      -> 
 		let [words] = args_stix
 		in  (\xs -> assign_hp words : cjmp_hp : 
-			    assts (gc_d1 : join : xs))
+			    assts (hp_alloc words : gc_d1 : join : xs))
 
 	HP_CHK_UT_ALT  -> 
                 let [words,ptrs,nonptrs,r,ret] = args_stix
                 in (\xs -> assign_hp words : cjmp_hp :
-                           assts (assign_ret r ret : gc_ut ptrs nonptrs 
+                           assts (hp_alloc words : assign_ret r ret
+				  : gc_ut ptrs nonptrs 
                                   : join : xs))
 
 	HP_CHK_GEN     -> 
                 let [words,liveness,reentry] = args_stix
                 in (\xs -> assign_hp words : cjmp_hp :
-                           assts (assign_liveness liveness :
+                           assts (hp_alloc words : assign_liveness liveness :
                                   assign_reentry reentry :
                                   gc_gen : join : xs))
     )
-	
+
 -- Various canned heap-check routines
 
 mkStJump_to_GCentry :: String -> StixTree
@@ -342,8 +347,13 @@ mkStJump_to_GCentry gcname
 --   | otherwise -- it's in a different DLL
 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 
+gc_chk (StInt 0)   = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk0)
+gc_chk (StInt 1)   = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgChk1)
 gc_chk (StInt n)   = mkStJump_to_GCentry ("stg_chk_" ++ show n)
+
+gc_enter (StInt 1) = StJump NoDestInfo (regTableEntry CodePtrRep OFFSET_stgGCEnter1)
 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
+
 gc_seq (StInt n)   = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
 gc_noregs          = mkStJump_to_GCentry "stg_gc_noregs"
 gc_unpt_r1         = mkStJump_to_GCentry "stg_gc_unpt_r1"
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index ef8614e72d..2c79450863 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -12,7 +12,7 @@ module Outputable (
 	Outputable(..),			-- Class
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
-	getPprStyle, withPprStyle, pprDeeper,
+	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
 	codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
 	ifPprDebug, unqualStyle,
 
@@ -34,7 +34,7 @@ module Outputable (
 
 	printSDoc, printErrs, printDump,
 	printForC, printForAsm, printForIface, printForUser,
-	pprCode, pprCols,
+	pprCode, mkCodeStyle,
 	showSDoc, showSDocForUser, showSDocDebug, showSDocIface, 
 	showSDocUnqual, showsPrecSDoc,
 	pprHsChar, pprHsString,
@@ -125,6 +125,9 @@ type SDoc = PprStyle -> Doc
 withPprStyle :: PprStyle -> SDoc -> SDoc
 withPprStyle sty d sty' = d sty
 
+withPprStyleDoc :: PprStyle -> SDoc -> Doc
+withPprStyleDoc sty d = d sty
+
 pprDeeper :: SDoc -> SDoc
 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
@@ -167,17 +170,17 @@ ifPprDebug d sty	  = Pretty.empty
 
 \begin{code}
 printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = printDoc PageMode stdout (d sty)
+printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
 
--- I'm not sure whether the direct-IO approach of printDoc
+-- I'm not sure whether the direct-IO approach of Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
 printErrs :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = printDoc PageMode stderr (doc style)
+printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
 		     where
 		       style = mkUserStyle unqual (PartWay opt_PprUserLength)
 
 printDump :: SDoc -> IO ()
-printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
+printDump doc = Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
   	      where
 		better_doc = doc $$ text ""
 	-- We used to always print in debug style, but I want
@@ -186,24 +189,27 @@ printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
-  = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 
 -- printForIface prints all on one line for interface files.
 -- It's called repeatedly for successive lines
 printForIface :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForIface handle unqual doc 
-  = printDoc LeftMode handle (doc (PprInterface unqual))
+  = Pretty.printDoc LeftMode handle (doc (PprInterface unqual))
 
 -- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 
 printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 
 pprCode :: CodeStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
 
+mkCodeStyle :: CodeStyle -> PprStyle
+mkCodeStyle = PprCode
+
 -- Can't make SDoc an instance of Show because SDoc is just a function type
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
@@ -398,18 +404,6 @@ instance Show FastString  where
 %************************************************************************
 
 \begin{code}
-pprCols = (100 :: Int) -- could make configurable
-
-printDoc :: Mode -> Handle -> Doc -> IO ()
-printDoc mode hdl doc
-  = fullRender mode pprCols 1.5 put done doc
-  where
-    put (Chr c)  next = hPutChar hdl c >> next 
-    put (Str s)  next = hPutStr  hdl s >> next 
-    put (PStr s) next = hPutFS   hdl s >> next 
-
-    done = hPutChar hdl '\n'
-
 showDocWith :: Mode -> Doc -> String
 showDocWith mode doc
   = fullRender mode 100 1.5 put "" doc
diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs
index 984655d7f5..c0336832c7 100644
--- a/ghc/compiler/utils/Pretty.lhs
+++ b/ghc/compiler/utils/Pretty.lhs
@@ -172,7 +172,7 @@ module Pretty (
         hang, punctuate,
         
 --      renderStyle,            -- Haskell 1.3 only
-        render, fullRender
+        render, fullRender, printDoc
   ) where
 
 #include "HsVersions.h"
@@ -180,6 +180,7 @@ module Pretty (
 import FastString
 import GlaExts
 import Numeric (fromRat)
+import IO
 
 -- Don't import Util( assertPanic ) because it makes a loop in the module structure
 
@@ -968,3 +969,17 @@ multi_ch n       ch = ch : multi_ch (n MINUS ILIT(1)) ch
 spaces ILIT(0) = ""
 spaces n       = ' ' : spaces (n MINUS ILIT(1))
 \end{code}
+
+\begin{code}
+pprCols = (100 :: Int) -- could make configurable
+
+printDoc :: Mode -> Handle -> Doc -> IO ()
+printDoc mode hdl doc
+  = fullRender mode pprCols 1.5 put done doc
+  where
+    put (Chr c)  next = hPutChar hdl c >> next 
+    put (Str s)  next = hPutStr  hdl s >> next 
+    put (PStr s) next = hPutFS   hdl s >> next 
+
+    done = hPutChar hdl '\n'
+\end{code}