%
% (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}
| 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
%
% (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}
CLabelType(..), labelType, labelDynamic,
pprCLabel
-#if ! OMIT_NATIVE_CODEGEN
- , pprCLabel_asm
-#endif
) where
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
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
+import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import IOExts
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 */
lazyMapUs )
import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) )
-import OrdList ( concatOL )
+import qualified Pretty
import Outputable
\end{code}
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)
$$ 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
$$
(text "code = ")
$$
- (vcat (map pprInstr flatInstrs))
+ (vcat (map (docToSDoc.pprInstr) flatInstrs))
)
tryGeneral (resv:resvs)
= case generalAlloc resv of
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.
order.
\begin{code}
-
type InstrBlock = OrdList Instr
x `bind` f = f x
-
\end{code}
Code extractor for an entire stix tree---stix statement level.
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
4 -> 2
8 -> 3
other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
- (int other)
+ (Outputable.int other)
\end{code}
\begin{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
-- 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)
-- 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
-> 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 ->
= 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
= 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
-- 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 ->
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
saveLoc,
spRel,
stgReg,
+ regTableEntry,
strImmLit
#if alpha_TARGET_ARCH
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}
= 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
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}
% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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
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"
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}
%************************************************************************
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");
})
#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
})
#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");
%************************************************************************
\begin{code}
-pprSize :: Size -> SDoc
+pprSize :: Size -> Doc
pprSize x = ptext (case x of
#if alpha_TARGET_ARCH
F -> SLIT("")
DF -> SLIT("d")
)
-pprStSize :: Size -> SDoc
+pprStSize :: Size -> Doc
pprStSize x = ptext (case x of
B -> SLIT("b")
Bu -> SLIT("b")
%************************************************************************
\begin{code}
-pprCond :: Cond -> SDoc
+pprCond :: Cond -> Doc
pprCond c = ptext (case c of {
#if alpha_TARGET_ARCH
%************************************************************************
\begin{code}
-pprImm :: Imm -> SDoc
+pprImm :: Imm -> Doc
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
%************************************************************************
\begin{code}
-pprAddr :: MachRegsAddr -> SDoc
+pprAddr :: MachRegsAddr -> Doc
#if alpha_TARGET_ARCH
pprAddr (AddrReg r) = parens (pprReg r)
%************************************************************************
\begin{code}
-pprInstr :: Instr -> SDoc
+pprInstr :: Instr -> Doc
--pprInstr (COMMENT s) = empty -- nuke 'em
pprInstr (COMMENT s)
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"
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 [
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 [
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
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',
pprOperand size op1
]
-pprSizeOp :: FAST_STRING -> Size -> Operand -> SDoc
+pprSizeOp :: FAST_STRING -> Size -> Operand -> Doc
pprSizeOp name size op1
= hcat [
char '\t',
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',
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',
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',
pprReg size reg
]
-pprSizeReg :: FAST_STRING -> Size -> Reg -> SDoc
+pprSizeReg :: FAST_STRING -> Size -> Reg -> Doc
pprSizeReg name size reg1
= hcat [
char '\t',
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',
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',
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',
pprReg size reg3
]
-pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
+pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> Doc
pprSizeAddr name size op
= hcat [
char '\t',
pprAddr op
]
-pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> SDoc
+pprSizeAddrReg :: FAST_STRING -> Size -> MachRegsAddr -> Reg -> Doc
pprSizeAddrReg name size op dst
= hcat [
char '\t',
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',
pprAddr op
]
-pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
+pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> Doc
pprOpOp name size op1 op2
= hcat [
char '\t',
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,
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]
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',
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',
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',
pprReg reg2
]
-pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> SDoc
+pprRIReg :: FAST_STRING -> Bool -> RI -> Reg -> Doc
pprRIReg name b ri reg1
= hcat [
char '\t',
DestInfo(..), hasDestInfo,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
- stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
+ stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
stgCurrentTSO, stgCurrentNursery,
fixedHS, arrWordsHS, arrPtrsHS,
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)))
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}
-----------------------------------------------------------------------------
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
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
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
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
-- | 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"
Outputable(..), -- Class
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
- getPprStyle, withPprStyle, pprDeeper,
+ getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
ifPprDebug, unqualStyle,
printSDoc, printErrs, printDump,
printForC, printForAsm, printForIface, printForUser,
- pprCode, pprCols,
+ pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocIface,
showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
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)))
\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
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
%************************************************************************
\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
hang, punctuate,
-- renderStyle, -- Haskell 1.3 only
- render, fullRender
+ render, fullRender, printDoc
) where
#include "HsVersions.h"
import FastString
import GlaExts
import Numeric (fromRat)
+import IO
-- Don't import Util( assertPanic ) because it makes a loop in the module structure
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}
projects / ghc-hetmet.git / commitdiff