From: simonmar Date: Thu, 8 Nov 2001 12:56:01 +0000 (+0000) Subject: [project @ 2001-11-08 12:56:00 by simonmar] X-Git-Tag: Approximately_9120_patches~603 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6ae381cd9ca394e33c0d67b09c8b15a6500b6083;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 9aa589b..2a6a827 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 c8712f5..4da5c57 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. 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 95401ce..3953410 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 e98648b..22b95a5 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 5922411..bd2b111 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 341c889..b2a4e82 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 904b612..0dce2fe 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 ab1e3d9..273a679 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 cc7a491..e8c27d1 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 6f4a5d1..d3888ed 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 ef8614e..2c79450 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 984655d..c033683 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}