2 % (c) The AQUA Project, Glasgow University, 1993-1998
7 CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
8 pprStixTrees, pprStixTree, ppStixReg,
9 stixCountTempUses, stixSubst,
10 DestInfo(..), hasDestInfo,
12 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
13 stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
14 stgCurrentTSO, stgCurrentNursery,
16 fixedHS, arrWordsHS, arrPtrsHS,
18 NatM, initNat, thenNat, returnNat,
19 mapNat, mapAndUnzipNat, mapAccumLNat,
20 getUniqueNat, getDeltaNat, setDeltaNat,
21 NatM_State, mkNatM_State,
22 uniqOfNatM_State, deltaOfNatM_State,
24 getUniqLabelNCG, getNatLabelNCG,
27 #include "HsVersions.h"
29 import Ratio ( Rational )
31 import AbsCSyn ( node, tagreg, MagicId(..) )
32 import ForeignCall ( CCallConv )
33 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
34 import PrimRep ( PrimRep(..) )
35 import PrimOp ( PrimOp )
36 import Unique ( Unique )
37 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
38 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
39 UniqSM, thenUs, returnUs, getUniqueUs )
44 Here is the tag at the nodes of our @StixTree@. Notice its
45 relationship with @PrimOp@ in prelude/PrimOp.
49 = -- Segment (text or data)
53 -- We can tag the leaves with constants/immediates.
55 | StInt Integer -- ** add Kind at some point
58 | StString FAST_STRING
59 | StCLbl CLabel -- labels that we might index into
61 -- Abstract registers of various kinds
65 -- A typed offset from a base location
67 | StIndex PrimRep StixTree StixTree -- kind, base, offset
69 -- An indirection from an address to its contents.
71 | StInd PrimRep StixTree
73 -- Assignment is typed to determine size and register placement
75 | StAssign PrimRep StixTree StixTree -- dst, src
77 -- A simple assembly label that we might jump to.
81 -- A function header and footer
86 -- An unconditional jump. This instruction may or may not jump
87 -- out of the register allocation domain (basic block, more or
88 -- less). For correct register allocation when this insn is used
89 -- to jump through a jump table, we optionally allow a list of
90 -- the exact targets to be attached, so that the allocator can
91 -- easily construct the exact flow edges leaving this insn.
92 -- Dynamic targets are allowed.
94 | StJump DestInfo StixTree
96 -- A fall-through, from slow to fast
98 | StFallThrough CLabel
100 -- A conditional jump. This instruction can be non-terminal :-)
101 -- Only static, local, forward labels are allowed
103 | StCondJump CLabel StixTree
105 -- Raw data (as in an info table).
107 | StData PrimRep [StixTree]
109 -- Primitive Operations
111 | StPrim PrimOp [StixTree]
113 -- Calls to C functions
115 | StCall FAST_STRING CCallConv PrimRep [StixTree]
117 -- A volatile memory scratch array, which is allocated
118 -- relative to the stack pointer. It is an array of
119 -- ptr/word/int sized things. Do not expect to be preserved
120 -- beyond basic blocks or over a ccall. Current max size
121 -- is 6, used in StixInteger.
125 -- Assembly-language comments
127 | StComment FAST_STRING
130 -- used by insnFuture in RegAllocInfo.lhs
132 = NoDestInfo -- no supplied dests; infer from context
133 | DestInfo [CLabel] -- precisely these dests and no others
135 hasDestInfo NoDestInfo = False
136 hasDestInfo (DestInfo _) = True
138 pprDests :: DestInfo -> SDoc
139 pprDests NoDestInfo = text "NoDestInfo"
140 pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
143 pprStixTrees :: [StixTree] -> SDoc
146 vcat (map pprStixTree ts),
151 paren t = char '(' <> t <> char ')'
152 brack t = char '[' <> t <> char ']'
154 pprStixTree :: StixTree -> SDoc
157 StSegment cseg -> paren (ppCodeSegment cseg)
158 StInt i -> paren (integer i)
159 StFloat rat -> paren (text "Float" <+> rational rat)
160 StDouble rat -> paren (text "Double" <+> rational rat)
161 StString str -> paren (text "Str `" <> ptext str <> char '\'')
162 StComment str -> paren (text "Comment" <+> ptext str)
163 StCLbl lbl -> pprCLabel lbl
164 StReg reg -> ppStixReg reg
165 StIndex k b o -> paren (pprStixTree b <+> char '+' <>
166 ppr k <+> pprStixTree o)
167 StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']'
168 StAssign k d s -> pprStixTree d <> text " :=" <> ppr k
169 <> text " " <> pprStixTree s
170 StLabel ll -> pprCLabel ll <+> char ':'
171 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
172 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
173 StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
174 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
175 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
177 StData k ds -> paren (text "Data" <+> ppr k <+>
178 hsep (map pprStixTree ds))
179 StPrim op ts -> paren (text "Prim" <+> ppr op <+>
180 hsep (map pprStixTree ts))
182 -> paren (text "Call" <+> ptext nm <+>
184 hsep (map pprStixTree args))
185 StScratchWord i -> text "ScratchWord" <> paren (int i)
188 Stix registers can have two forms. They {\em may} or {\em may not}
189 map to real, machine-level registers.
193 = StixMagicId MagicId -- Regs which are part of the abstract machine model
195 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
198 ppStixReg (StixMagicId mid)
200 ppStixReg (StixTemp u pr)
201 = hcat [text "Temp(", ppr u, ppr pr, char ')']
204 ppMId BaseReg = text "BaseReg"
205 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
206 int (iBox n), char ')']
207 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
208 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
209 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
210 int (iBox n), char ')']
213 ppMId SpLim = text "SpLim"
215 ppMId HpLim = text "HpLim"
216 ppMId CurCostCentre = text "CCC"
217 ppMId VoidReg = text "VoidReg"
220 We hope that every machine supports the idea of data segment and text
221 segment (or that it has no segments at all, and we can lump these
225 data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
226 ppCodeSegment = text . show
228 type StixTreeList = [StixTree] -> [StixTree]
231 Stix Trees for STG registers:
233 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
236 stgBaseReg = StReg (StixMagicId BaseReg)
237 stgNode = StReg (StixMagicId node)
238 stgTagReg = StReg (StixMagicId tagreg)
239 stgSp = StReg (StixMagicId Sp)
240 stgSu = StReg (StixMagicId Su)
241 stgSpLim = StReg (StixMagicId SpLim)
242 stgHp = StReg (StixMagicId Hp)
243 stgHpLim = StReg (StixMagicId HpLim)
244 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
245 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
246 stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
247 stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
249 getNatLabelNCG :: NatM CLabel
251 = getUniqueNat `thenNat` \ u ->
252 returnNat (mkAsmTempLabel u)
254 getUniqLabelNCG :: UniqSM CLabel
256 = getUniqueUs `thenUs` \ u ->
257 returnUs (mkAsmTempLabel u)
259 fixedHS = StInt (toInteger fixedHdrSize)
260 arrWordsHS = StInt (toInteger arrWordsHdrSize)
261 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
264 Stix optimisation passes may wish to find out how many times a
265 given temporary appears in a tree, so as to be able to decide
266 whether or not to inline the assignment's RHS at usage site(s).
269 stixCountTempUses :: Unique -> StixTree -> Int
270 stixCountTempUses u t
271 = let qq = stixCountTempUses u
276 StixTemp uu pr -> if u == uu then 1 else 0
279 StIndex pk t1 t2 -> qq t1 + qq t2
281 StAssign pk t1 t2 -> qq t1 + qq t2
282 StJump dsts t1 -> qq t1
283 StCondJump lbl t1 -> qq t1
284 StData pk ts -> sum (map qq ts)
285 StPrim op ts -> sum (map qq ts)
286 StCall nm cconv pk ts -> sum (map qq ts)
302 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
303 stixSubst u new_u in_this_tree
304 = stixMapUniques f in_this_tree
306 f :: Unique -> Maybe StixTree
307 f uu = if uu == u then Just new_u else Nothing
310 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
312 = let qq = stixMapUniques f
323 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
324 StInd pk t1 -> StInd pk (qq t1)
325 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
326 StJump dsts t1 -> StJump dsts (qq t1)
327 StCondJump lbl t1 -> StCondJump lbl (qq t1)
328 StData pk ts -> StData pk (map qq ts)
329 StPrim op ts -> StPrim op (map qq ts)
330 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
347 data NatM_State = NatM_State UniqSupply Int
348 type NatM result = NatM_State -> (result, NatM_State)
350 mkNatM_State :: UniqSupply -> Int -> NatM_State
351 mkNatM_State = NatM_State
353 uniqOfNatM_State (NatM_State us delta) = us
354 deltaOfNatM_State (NatM_State us delta) = delta
357 initNat :: NatM_State -> NatM a -> (a, NatM_State)
358 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
360 thenNat :: NatM a -> (a -> NatM b) -> NatM b
362 = case expr st of { (result, st') -> cont result st' }
364 returnNat :: a -> NatM a
365 returnNat result st = (result, st)
367 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
368 mapNat f [] = returnNat []
370 = f x `thenNat` \ r ->
371 mapNat f xs `thenNat` \ rs ->
374 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
375 mapAndUnzipNat f [] = returnNat ([],[])
376 mapAndUnzipNat f (x:xs)
377 = f x `thenNat` \ (r1, r2) ->
378 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
379 returnNat (r1:rs1, r2:rs2)
381 mapAccumLNat :: (acc -> x -> NatM (acc, y))
388 mapAccumLNat f b (x:xs)
389 = f b x `thenNat` \ (b__2, x__2) ->
390 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
391 returnNat (b__3, x__2:xs__2)
394 getUniqueNat :: NatM Unique
395 getUniqueNat (NatM_State us delta)
396 = case splitUniqSupply us of
397 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
399 getDeltaNat :: NatM Int
400 getDeltaNat st@(NatM_State us delta)
403 setDeltaNat :: Int -> NatM ()
404 setDeltaNat delta (NatM_State us _)
405 = ((), NatM_State us delta)