Commit 963cf411 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-05-18 13:55:36 by sewardj]

Teach the NCG about the dereferencing and naming conventions to be
used when compiling for a DLLised world.  Some cleanups on the way
too.  The scheme is that

* All CLabels which are in different DLLs from the current module
  will, via the renamer, already be such that labelDynamic returns
  True for them.

* Redo the StixPrim/StixMacro stuff so that all references to symbols
  in the RTS are via CLabels.  That means that the usual labelDynamic
  story can be used.

* When a label is printed in PprMach, labelDynamic is consulted, to
  generate the __imp_ prefix if necessary.

* In MachCode.stmt2Instrs, selectively ask derefDLL to walk trees
  before code generation and insert deferencing code around other-DLL
  symbols.

* When generating Stix for SRTs, add 1 to other-DLL refs.

* When generating static closures, insert a zero word before
  the _closure label.
parent 6f191b69
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CLabel.lhs,v 1.34 2000/05/15 15:03:36 simonmar Exp $
% $Id: CLabel.lhs,v 1.35 2000/05/18 13:55:36 sewardj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
......@@ -36,7 +36,20 @@ module CLabel (
mkModuleInitLabel,
mkErrorStdEntryLabel,
mkStgUpdatePAPLabel,
mkUpdInfoLabel,
mkSeqInfoLabel,
mkIndInfoLabel,
mkIndStaticInfoLabel,
mkRtsGCEntryLabel,
mkMainRegTableLabel,
mkCharlikeClosureLabel,
mkIntlikeClosureLabel,
mkTopClosureLabel,
mkErrorIO_innardsLabel,
mkMAP_FROZEN_infoLabel,
mkTopTickyCtrLabel,
mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
......@@ -160,7 +173,13 @@ data RtsLabelInfo
| RtsBlackHoleInfoTbl FAST_STRING -- black hole with info table name
| RtsUpdInfo
| RtsUpdInfo -- upd_frame_info
| RtsSeqInfo -- seq_frame_info
| RtsGCEntryLabel String -- a heap check fail handler, eg stg_chk_2
| RtsMainRegTable -- MainRegTable (??? Capabilities wurble ???)
| Rts_Closure String -- misc rts closures, eg CHARLIKE_closure
| Rts_Info String -- misc rts itbls, eg MUT_ARR_PTRS_FROZEN_info
| Rts_Code String -- misc rts code, eg ErrorIO_innards
| RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks
| RtsSelectorEntry Bool{-updatable-} Int{-offset-}
......@@ -219,7 +238,20 @@ mkModuleInitLabel = ModuleInitLabel
-- Some fixed runtime system labels
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkStgUpdatePAPLabel = RtsLabel (Rts_Code "stg_update_PAP")
mkUpdInfoLabel = RtsLabel RtsUpdInfo
mkSeqInfoLabel = RtsLabel RtsSeqInfo
mkIndInfoLabel = RtsLabel (Rts_Info "IND_info")
mkIndStaticInfoLabel = RtsLabel (Rts_Info "IND_STATIC_info")
mkRtsGCEntryLabel str = RtsLabel (RtsGCEntryLabel str)
mkMainRegTableLabel = RtsLabel RtsMainRegTable
mkCharlikeClosureLabel = RtsLabel (Rts_Closure "CHARLIKE_closure")
mkIntlikeClosureLabel = RtsLabel (Rts_Closure "INTLIKE_closure")
mkTopClosureLabel = RtsLabel (Rts_Closure "TopClosure")
mkErrorIO_innardsLabel = RtsLabel (Rts_Code "ErrorIO_innards")
mkMAP_FROZEN_infoLabel = RtsLabel (Rts_Info "MUT_ARR_PTRS_FROZEN_info")
mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
......@@ -418,7 +450,13 @@ pprCLbl (CaseLabel u CaseBitmap)
pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("upd_frame_info")
pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("upd_frame_info")
pprCLbl (RtsLabel RtsSeqInfo) = ptext SLIT("seq_frame_info")
pprCLbl (RtsLabel RtsMainRegTable) = ptext SLIT("MainRegTable")
pprCLbl (RtsLabel (RtsGCEntryLabel str)) = text str
pprCLbl (RtsLabel (Rts_Closure str)) = text str
pprCLbl (RtsLabel (Rts_Info str)) = text str
pprCLbl (RtsLabel (Rts_Code str)) = text str
pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
......
......@@ -24,7 +24,7 @@ import SMRep ( fixedItblSize,
import Constants ( mIN_UPD_SIZE )
import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
mkClosureTblLabel, mkClosureLabel,
moduleRegdLabel )
moduleRegdLabel, labelDynamic )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd,
staticClosureNeedsLink
......@@ -45,6 +45,7 @@ import DataCon ( dataConWrapId )
import BitSet ( intBS )
import Name ( NamedThing(..) )
import Char ( ord )
import CmdLineOpts ( opt_Static )
\end{code}
For each independent chunk of AbstractC code, we generate a list of
......@@ -84,7 +85,14 @@ Here we handle top-level things, like @CCodeBlock@s and
gentopcode stmt@(CStaticClosure lbl _ _ _)
= genCodeStaticClosure stmt `thenUs` \ code ->
returnUs (StSegment DataSegment : StLabel lbl : code [])
returnUs (
if opt_Static
then StSegment DataSegment
: StLabel lbl : code []
else StSegment DataSegment
: StData PtrRep [StInt 0] -- DLLised world, need extra zero word
: StLabel lbl : code []
)
gentopcode stmt@(CRetVector lbl _ _ _)
= genCodeVecTbl stmt `thenUs` \ code ->
......@@ -132,8 +140,15 @@ Here we handle top-level things, like @CCodeBlock@s and
gentopcode stmt@(CSRT lbl closures)
= returnUs [ StSegment TextSegment
, StLabel lbl
, StData DataPtrRep (map StCLbl closures)
, StData DataPtrRep (map mk_StCLbl_for_SRT closures)
]
where
mk_StCLbl_for_SRT :: CLabel -> StixTree
mk_StCLbl_for_SRT label
| labelDynamic label
= StIndex CharRep (StCLbl label) (StInt 1)
| otherwise
= StCLbl label
gentopcode stmt@(CBitmap lbl mask)
= returnUs [ StSegment TextSegment
......@@ -152,18 +167,20 @@ Here we handle top-level things, like @CCodeBlock@s and
gentopcode stmt@(CModuleInitBlock lbl absC)
= gencode absC `thenUs` \ code ->
getUniqLabelNCG `thenUs` \ tmp_lbl ->
getUniqLabelNCG `thenUs` \ flag_lbl ->
returnUs ( StSegment DataSegment
: StLabel moduleRegdLabel
: StLabel flag_lbl
: StData IntRep [StInt 0]
: StSegment TextSegment
: StLabel lbl
: StCondJump tmp_lbl (StPrim IntNeOp
[StInd IntRep (StCLbl moduleRegdLabel),
[StInd IntRep (StCLbl flag_lbl),
StInt 0])
: StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1)
: StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
: code
[ StLabel tmp_lbl
, StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4])
, StAssign PtrRep stgSp
(StIndex PtrRep stgSp (StInt (-1)))
, StJump (StInd WordRep stgSp)
])
......
......@@ -22,7 +22,7 @@ import AsmRegAlloc ( runRegAllocate )
import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState, findReservedRegs )
import Stix ( StixTree(..), StixReg(..),
pprStixTrees, ppStixTree, CodeSegment(..),
pprStixTrees, pprStixTree, CodeSegment(..),
stixCountTempUses, stixSubst,
NatM, initNat, mapNat,
NatM_State, mkNatM_State,
......@@ -203,7 +203,7 @@ stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs)
: ts )
| stixCountTempUses u t2 == 1
&& sum (map (stixCountTempUses u) ts) == 0
= trace ("nativeGen: stixInline: " ++ showSDoc (ppStixTree rhs))
= trace ("nativeGen: stixInline: " ++ showSDoc (pprStixTree rhs))
(stixPeep (stixSubst u rhs t2 : ts))
stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
......
......@@ -163,9 +163,9 @@ hairyRegAlloc regs reserve_regs instrs =
noFuture instrs_patched of
((RH _ mloc2 _),_,instrs'')
-- successfully allocated the patched code
| mloc2 == mloc1 -> trace (spillMsg True) (Just instrs'')
| mloc2 == mloc1 -> maybetrace (spillMsg True) (Just instrs'')
-- no; we have to give up
| otherwise -> trace (spillMsg False) Nothing
| otherwise -> maybetrace (spillMsg False) Nothing
-- instrs''
where
regs' = regs `useMRegs` reserve_regs
......@@ -182,6 +182,12 @@ hairyRegAlloc regs reserve_regs instrs =
(reverse reserve_regs)))
where
toMappedReg (I# i) = MappedReg i
#ifdef DEBUG
maybetrace msg x = trace msg x
#else
maybetrace msg x = x
#endif
\end{code}
Here we patch instructions that reference ``registers'' which are
......
......@@ -21,19 +21,20 @@ import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
pprStixTrees, ppStixReg,
pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
)
import Outputable
import CmdLineOpts ( opt_Static )
infixr 3 `bind`
......@@ -68,13 +69,16 @@ stmt2Instrs stmt = case stmt of
StLabel lab -> returnNat (unitOL (LABEL lab))
StJump arg -> genJump arg
StCondJump lab arg -> genCondJump lab arg
StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
StJump arg -> genJump (derefDLL arg)
StCondJump lab arg -> genCondJump lab (derefDLL arg)
-- A call returning void, ie one done for its side-effects
StCall fn cconv VoidRep args -> genCCall fn
cconv VoidRep (map derefDLL args)
StAssign pk dst src
| isFloatingRep pk -> assignFltCode pk dst src
| otherwise -> assignIntCode pk dst src
| isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
| otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
StFallThrough lbl
-- When falling through on the Alpha, we still have to load pv
......@@ -89,11 +93,10 @@ stmt2Instrs stmt = case stmt of
where
getData :: StixTree -> NatM (InstrBlock, Imm)
getData (StInt i) = returnNat (nilOL, ImmInteger i)
getData (StDouble d) = returnNat (nilOL, ImmDouble d)
getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
getData (StString s) =
getData (StInt i) = returnNat (nilOL, ImmInteger i)
getData (StDouble d) = returnNat (nilOL, ImmDouble d)
getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
getData (StString s) =
getNatLabelNCG `thenNat` \ lbl ->
returnNat (toOL [LABEL lbl,
ASCII True (_UNPK_ s)],
......@@ -102,6 +105,35 @@ stmt2Instrs stmt = case stmt of
getData (StIndex rep (StCLbl lbl) (StInt off)) =
returnNat (nilOL,
ImmIndex lbl (fromInteger (off * sizeOf rep)))
-- Walk a Stix tree, and insert dereferences to CLabels which are marked
-- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
-- not all such CLabel occurrences need this dereferencing -- SRTs don't
-- for one.
derefDLL :: StixTree -> StixTree
derefDLL tree
| opt_Static -- short out the entire deal if not doing DLLs
= tree
| otherwise
= qq tree
where
qq t
= case t of
StCLbl lbl -> if labelDynamic lbl
then StInd PtrRep (StCLbl lbl)
else t
-- all the rest are boring
StIndex pk base offset -> StIndex pk (qq base) (qq offset)
StPrim pk args -> StPrim pk (map qq args)
StInd pk addr -> StInd pk (qq addr)
StCall who cc pk args -> StCall who cc pk (map qq args)
StInt _ -> t
StDouble _ -> t
StString _ -> t
StReg _ -> t
StScratchWord _ -> t
_ -> pprPanic "derefDLL: unhandled case"
(pprStixTree t)
\end{code}
%************************************************************************
......@@ -134,12 +166,10 @@ mangleIndexTree (StIndex pk base off)
\begin{code}
maybeImm :: StixTree -> Maybe Imm
maybeImm (StLitLbl s) = Just (ImmLab s)
maybeImm (StCLbl l) = Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off)) =
Just (ImmIndex l (fromInteger (off * sizeOf rep)))
maybeImm (StCLbl l)
= Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off))
= Just (ImmIndex l (fromInteger (off * sizeOf rep)))
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
......@@ -482,13 +512,11 @@ getRegister (StDouble d)
| d == 0.0
= let code dst = unitOL (GLDZ dst)
in trace "nativeGen: GLDZ"
(returnNat (Any DoubleRep code))
in returnNat (Any DoubleRep code)
| d == 1.0
= let code dst = unitOL (GLD1 dst)
in trace "nativeGen: GLD1"
returnNat (Any DoubleRep code)
in returnNat (Any DoubleRep code)
| otherwise
= getNatLabelNCG `thenNat` \ lbl ->
......@@ -578,7 +606,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
other
-> pprPanic "getRegister(x86,unary primop)"
(pprStixTrees [StPrim primop [x]])
(pprStixTree (StPrim primop [x]))
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
......@@ -662,7 +690,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
[x, y])
other
-> pprPanic "getRegister(x86,dyadic primop)"
(pprStixTrees [StPrim primop [x, y]])
(pprStixTree (StPrim primop [x, y]))
where
--------------------
......@@ -861,7 +889,7 @@ getRegister leaf
in
returnNat (Any PtrRep code)
| otherwise
= pprPanic "getRegister(x86)" (pprStixTrees [leaf])
= pprPanic "getRegister(x86)" (pprStixTree leaf)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
......@@ -2317,7 +2345,7 @@ genCCall fn cconv kind args
-- ToDo:needed (WDP 96/03) ???
fn__2 = case (_HEAD_ fn) of
'.' -> ImmLit (ptext fn)
_ -> ImmLab (ptext fn)
_ -> ImmLab False (ptext fn)
arg_size DF = 8
arg_size F = 8
......
......@@ -20,8 +20,6 @@ module MachMisc (
fmtAsmLbl,
exactLog2,
stixFor_stdout, stixFor_stderr, stixFor_stdin,
Instr(..), IF_ARCH_i386(Operand(..) COMMA,)
Cond(..),
Size(..),
......@@ -80,53 +78,6 @@ fmtAsmLbl s
,{-otherwise-}
'.':'L':s
)
---------------------------
stixFor_stdout, stixFor_stderr, stixFor_stdin :: StixTree
#if i386_TARGET_ARCH
-- Linux glibc 2 / libc6
stixFor_stdout = StInd PtrRep (StLitLbl (text "stdout"))
stixFor_stderr = StInd PtrRep (StLitLbl (text "stderr"))
stixFor_stdin = StInd PtrRep (StLitLbl (text "stdin"))
#endif
#if alpha_TARGET_ARCH
stixFor_stdout = error "stixFor_stdout: not implemented for Alpha"
stixFor_stderr = error "stixFor_stderr: not implemented for Alpha"
stixFor_stdin = error "stixFor_stdin: not implemented for Alpha"
#endif
#if sparc_TARGET_ARCH
stixFor_stdout = error "stixFor_stdout: not implemented for Sparc"
stixFor_stderr = error "stixFor_stderr: not implemented for Sparc"
stixFor_stdin = error "stixFor_stdin: not implemented for Sparc"
#endif
#if 0
Here's some old stuff from which it shouldn't be too hard to
implement the above for Alpha/Sparc.
cvtLitLit :: String -> String
--
-- Rather than relying on guessing, use FILE_SIZE to compute the
-- _iob offsets.
--
cvtLitLit "stdin" = IF_ARCH_alpha("_iob+0" {-probably OK...-}
,IF_ARCH_i386("stdin"
,IF_ARCH_sparc("__iob+0x0"{-probably OK...-}
,)))
cvtLitLit "stdout" = IF_ARCH_alpha("_iob+"++show (``FILE_SIZE''::Int)
,IF_ARCH_i386("stdout"
,IF_ARCH_sparc("__iob+"++show (``FILE_SIZE''::Int)
,)))
cvtLitLit "stderr" = IF_ARCH_alpha("_iob+"++show (2*(``FILE_SIZE''::Int))
,IF_ARCH_i386("stderr"
,IF_ARCH_sparc("__iob+"++show (2*(``FILE_SIZE''::Int))
,)))
#endif
\end{code}
% ----------------------------------------------------------------
......
......@@ -61,10 +61,10 @@ module MachRegs (
import AbsCSyn ( MagicId(..) )
import AbsCUtils ( magicIdPrimRep )
import CLabel ( CLabel )
import CLabel ( CLabel, mkMainRegTableLabel )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import Stix ( sStLitLbl, StixTree(..), StixReg(..),
import Stix ( StixTree(..), StixReg(..),
getUniqueNat, returnNat, thenNat, NatM )
import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Uniquable(..), Unique
......@@ -80,7 +80,8 @@ data Imm
= ImmInt Int
| ImmInteger Integer -- Sigh.
| ImmCLbl CLabel -- AbstractC Label (with baggage)
| ImmLab SDoc -- Simple string label (underscore-able)
| ImmLab Bool SDoc -- Simple string label (underscore-able)
-- Bool==True ==> in a different DLL
| ImmLit SDoc -- Simple string
| ImmIndex CLabel Int
| ImmDouble Rational
......@@ -169,7 +170,9 @@ fits13Bits x = x >= -4096 && x < 4096
-----------------
largeOffsetError i
= error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
= error ("ERROR: SPARC native-code generator cannot handle large offset ("
++show i++");\nprobably because of large constant data structures;" ++
"\nworkaround: use -fvia-C on this module.\n")
#endif {-sparc-}
\end{code}
......@@ -204,10 +207,10 @@ stgReg x
baseLoc = case (magicIdRegMaybe BaseReg) of
Just _ -> StReg (StixMagicId BaseReg)
Nothing -> sStLitLbl SLIT("MainRegTable")
Nothing -> StCLbl mkMainRegTableLabel
nonReg = case x of
BaseReg -> sStLitLbl SLIT("MainRegTable")
BaseReg -> StCLbl mkMainRegTableLabel
_ -> StInd (magicIdPrimRep x)
(StPrim IntAddOp [baseLoc,
......
......@@ -17,7 +17,7 @@ module PprMach ( pprInstr, pprSize, pprUserReg ) where
import MachRegs -- may differ per-platform
import MachMisc
import CLabel ( pprCLabel_asm, externallyVisibleCLabel )
import CLabel ( pprCLabel_asm, externallyVisibleCLabel, labelDynamic )
import CStrings ( charToC )
import Maybes ( maybeToBool )
import Stix ( CodeSegment(..), StixTree(..) )
......@@ -260,12 +260,15 @@ pprImm :: Imm -> SDoc
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
pprImm (ImmCLbl l) = pprCLabel_asm l
pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty)
<> pprCLabel_asm l
pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
<> pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
pprImm (ImmLab s) | underscorePrefix = (<>) (char '_') s
| otherwise = s
pprImm (ImmLab dll s) = (if underscorePrefix then char '_' else empty)
<> (if dll then text "_imp__" else empty)
<> s
#if sparc_TARGET_ARCH
pprImm (LO i)
......
......@@ -5,7 +5,7 @@
\begin{code}
module Stix (
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
sStLitLbl, pprStixTrees, ppStixTree, ppStixReg,
pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
......@@ -37,6 +37,7 @@ import Unique ( Unique )
import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
UniqSM, thenUs, returnUs, getUniqueUs )
import CmdLineOpts ( opt_Static )
import Outputable
\end{code}
......@@ -54,9 +55,6 @@ data StixTree
| StInt Integer -- ** add Kind at some point
| StDouble Rational
| StString FAST_STRING
| StLitLbl SDoc -- literal labels
-- (will be _-prefixed on some machines)
| StCLbl CLabel -- labels that we might index into
-- Abstract registers of various kinds
......@@ -122,51 +120,47 @@ data StixTree
| StComment FAST_STRING
sStLitLbl :: FAST_STRING -> StixTree
sStLitLbl s = StLitLbl (ptext s)
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
vcat (map ppStixTree ts),
vcat (map pprStixTree ts),
char ' ',
char ' '
]
paren t = char '(' <> t <> char ')'
ppStixTree :: StixTree -> SDoc
ppStixTree t
pprStixTree :: StixTree -> SDoc
pprStixTree t
= case t of
StSegment cseg -> paren (ppCodeSegment cseg)
StInt i -> paren (integer i)
StDouble rat -> paren (text "Double" <+> rational rat)
StString str -> paren (text "Str" <+> ptext str)
StComment str -> paren (text "Comment" <+> ptext str)
StLitLbl sd -> sd
StCLbl lbl -> pprCLabel lbl
StReg reg -> ppStixReg reg
StIndex k b o -> paren (ppStixTree b <+> char '+' <>
pprPrimRep k <+> ppStixTree o)
StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']'
StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k
<> text " " <> ppStixTree s
StIndex k b o -> paren (pprStixTree b <+> char '+' <>
pprPrimRep k <+> pprStixTree o)
StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
<> text " " <> pprStixTree s
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
StJump t -> paren (text "Jump" <+> ppStixTree t)
StJump t -> paren (text "Jump" <+> pprStixTree t)
StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
<+> ppStixTree t)
<+> pprStixTree t)
StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
hsep (map ppStixTree ds))
hsep (map pprStixTree ds))
StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
hsep (map ppStixTree ts))
hsep (map pprStixTree ts))
StCall nm cc k args
-> paren (text "Call" <+> ptext nm <+>
pprCallConv cc <+> pprPrimRep k <+>
hsep (map ppStixTree args))
hsep (map pprStixTree args))
StScratchWord i -> text "ScratchWord" <> paren (int i)
pprPrimRep = text . showPrimRep
......@@ -276,7 +270,6 @@ stixCountTempUses u t
StInt _ -> 0
StDouble _ -> 0
StString _ -> 0
StLitLbl _ -> 0
StCLbl _ -> 0
StLabel _ -> 0
StFunBegin _ -> 0
......@@ -320,7 +313,6 @@ stixMapUniques f t
StInt _ -> t
StDouble _ -> t
StString _ -> t
StLitLbl _ -> t
StCLbl _ -> t
StLabel _ -> t
StFunBegin _ -> t
......
......@@ -23,7 +23,7 @@ import CallConv ( cCallConv )
import PrimOp ( PrimOp(..) )
import PrimRep ( PrimRep(..) )
import SMRep ( arrWordsHdrSize )
import Stix ( sStLitLbl, StixTree(..), StixTreeList, arrWordsHS )
import Stix ( StixTree(..), StixTreeList, arrWordsHS )
import UniqSupply ( returnUs, thenUs, UniqSM )
\end{code}
......
......@@ -21,6 +21,9 @@ import PrimRep ( PrimRep(..) )
import Stix
import UniqSupply ( returnUs, thenUs, UniqSM )
import Outputable
import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
\end{code}
The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
......@@ -202,17 +205,17 @@ Let's make sure that these CAFs are lifted out, shall we?
bh_info, ind_static_info, ind_info :: StixTree
bh_info = sStLitLbl SLIT("BLACKHOLE_info")
ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
ind_info = sStLitLbl SLIT("IND_info")
upd_frame_info = sStLitLbl SLIT("upd_frame_info")
seq_frame_info = sStLitLbl SLIT("seq_frame_info")
bh_info = StCLbl mkBlackHoleInfoTableLabel
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
updatePAP = StJump (sStLitLbl SLIT("stg_update_PAP"))
updatePAP = StJump stg_update_PAP
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []