\begin{code}
module Stix (
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
- sStLitLbl, pprStixTrees, ppStixTree, ppStixReg,
+ pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
+ DestInfo(..),
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
- stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
+ stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
+ stgCurrentTSO, stgCurrentNursery,
fixedHS, arrWordsHS, arrPtrsHS,
NatM, initNat, thenNat, returnNat,
- mapNat, mapAndUnzipNat,
+ mapNat, mapAndUnzipNat, mapAccumLNat,
getUniqueNat, getDeltaNat, setDeltaNat,
NatM_State, mkNatM_State,
uniqOfNatM_State, deltaOfNatM_State,
import Ratio ( Rational )
import AbsCSyn ( node, tagreg, MagicId(..) )
-import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv, pprCallConv )
import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm )
import PrimRep ( PrimRep(..), showPrimRep )
-- We can tag the leaves with constants/immediates.
| StInt Integer -- ** add Kind at some point
+ | StFloat Rational
| 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
| StFunBegin CLabel
| StFunEnd CLabel
- -- An unconditional jump. This instruction is terminal.
- -- Dynamic targets are allowed
+ -- An unconditional jump. This instruction may or may not jump
+ -- out of the register allocation domain (basic block, more or
+ -- less). For correct register allocation when this insn is used
+ -- to jump through a jump table, we optionally allow a list of
+ -- the exact targets to be attached, so that the allocator can
+ -- easily construct the exact flow edges leaving this insn.
+ -- Dynamic targets are allowed.
- | StJump StixTree
+ | StJump DestInfo StixTree
-- A fall-through, from slow to fast
| StComment FAST_STRING
-sStLitLbl :: FAST_STRING -> StixTree
-sStLitLbl s = StLitLbl (ptext s)
+
+-- used by insnFuture in RegAllocInfo.lhs
+data DestInfo
+ = NoDestInfo -- no supplied dests; infer from context
+ | DestInfo [CLabel] -- precisely these dests and no others
+
+pprDests :: DestInfo -> SDoc
+pprDests NoDestInfo = text "NoDestInfo"
+pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
- vcat (map ppStixTree ts),
+ vcat (map pprStixTree ts),
char ' ',
char ' '
]
paren t = char '(' <> t <> char ')'
+brack 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)
+ StFloat rat -> paren (text "Float" <+> rational rat)
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 dsts t -> paren (text "Jump" <+> pprDests dsts <+> 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
stgSpLim = StReg (StixMagicId SpLim)
stgHp = StReg (StixMagicId Hp)
stgHpLim = StReg (StixMagicId HpLim)
+stgCurrentTSO = StReg (StixMagicId CurrentTSO)
+stgCurrentNursery = StReg (StixMagicId CurrentNursery)
stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
StIndex pk t1 t2 -> qq t1 + qq t2
StInd pk t1 -> qq t1
StAssign pk t1 t2 -> qq t1 + qq t2
- StJump t1 -> qq t1
+ StJump dsts t1 -> qq t1
StCondJump lbl t1 -> qq t1
StData pk ts -> sum (map qq ts)
StPrim op ts -> sum (map qq ts)
StSegment _ -> 0
StInt _ -> 0
+ StFloat _ -> 0
StDouble _ -> 0
StString _ -> 0
- StLitLbl _ -> 0
StCLbl _ -> 0
StLabel _ -> 0
StFunBegin _ -> 0
StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
StInd pk t1 -> StInd pk (qq t1)
StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
- StJump t1 -> StJump (qq t1)
+ StJump dsts t1 -> StJump dsts (qq t1)
StCondJump lbl t1 -> StCondJump lbl (qq t1)
StData pk ts -> StData pk (map qq ts)
StPrim op ts -> StPrim op (map qq ts)
StSegment _ -> t
StInt _ -> t
+ StFloat _ -> t
StDouble _ -> t
StString _ -> t
- StLitLbl _ -> t
StCLbl _ -> t
StLabel _ -> t
StFunBegin _ -> t
mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
returnNat (r1:rs1, r2:rs2)
+mapAccumLNat :: (acc -> x -> NatM (acc, y))
+ -> acc
+ -> [x]
+ -> NatM (acc, [y])
+
+mapAccumLNat f b []
+ = returnNat (b, [])
+mapAccumLNat f b (x:xs)
+ = f b x `thenNat` \ (b__2, x__2) ->
+ mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
+ returnNat (b__3, x__2:xs__2)
+
getUniqueNat :: NatM Unique
getUniqueNat (NatM_State us delta)
projects / ghc-hetmet.git / blobdiff