diff options
| -rw-r--r-- | ghc/compiler/absCSyn/AbsCSyn.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/absCSyn/CLabel.lhs | 10 | ||||
| -rw-r--r-- | ghc/compiler/main/CodeOutput.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/AsmCodeGen.lhs | 14 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/AsmRegAlloc.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachCode.lhs | 48 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/MachRegs.lhs | 38 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/PprMach.lhs | 94 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/Stix.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/nativeGen/StixMacro.lhs | 46 | ||||
| -rw-r--r-- | ghc/compiler/utils/Outputable.lhs | 38 | ||||
| -rw-r--r-- | ghc/compiler/utils/Pretty.lhs | 17 |
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} |