2 % (c) The AQUA Project, Glasgow University, 1993-1998
7 CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
8 pprStixTrees, pprStixTree, ppStixReg,
9 stixCountTempUses, stixSubst,
11 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
12 stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
13 stgCurrentTSO, stgCurrentNursery,
15 fixedHS, arrWordsHS, arrPtrsHS,
17 NatM, initNat, thenNat, returnNat,
18 mapNat, mapAndUnzipNat, mapAccumLNat,
19 getUniqueNat, getDeltaNat, setDeltaNat,
20 NatM_State, mkNatM_State,
21 uniqOfNatM_State, deltaOfNatM_State,
23 getUniqLabelNCG, getNatLabelNCG,
26 #include "HsVersions.h"
28 import Ratio ( Rational )
30 import AbsCSyn ( node, tagreg, MagicId(..) )
31 import CallConv ( CallConv, pprCallConv )
32 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm )
33 import PrimRep ( PrimRep(..), showPrimRep )
34 import PrimOp ( PrimOp, pprPrimOp )
35 import Unique ( Unique )
36 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
37 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
38 UniqSM, thenUs, returnUs, getUniqueUs )
42 Here is the tag at the nodes of our @StixTree@. Notice its
43 relationship with @PrimOp@ in prelude/PrimOp.
47 = -- Segment (text or data)
51 -- We can tag the leaves with constants/immediates.
53 | StInt Integer -- ** add Kind at some point
56 | StString FAST_STRING
57 | StCLbl CLabel -- labels that we might index into
59 -- Abstract registers of various kinds
63 -- A typed offset from a base location
65 | StIndex PrimRep StixTree StixTree -- kind, base, offset
67 -- An indirection from an address to its contents.
69 | StInd PrimRep StixTree
71 -- Assignment is typed to determine size and register placement
73 | StAssign PrimRep StixTree StixTree -- dst, src
75 -- A simple assembly label that we might jump to.
79 -- A function header and footer
84 -- An unconditional jump. This instruction is terminal.
85 -- Dynamic targets are allowed
89 -- A fall-through, from slow to fast
91 | StFallThrough CLabel
93 -- A conditional jump. This instruction can be non-terminal :-)
94 -- Only static, local, forward labels are allowed
96 | StCondJump CLabel StixTree
98 -- Raw data (as in an info table).
100 | StData PrimRep [StixTree]
102 -- Primitive Operations
104 | StPrim PrimOp [StixTree]
106 -- Calls to C functions
108 | StCall FAST_STRING CallConv PrimRep [StixTree]
110 -- A volatile memory scratch array, which is allocated
111 -- relative to the stack pointer. It is an array of
112 -- ptr/word/int sized things. Do not expect to be preserved
113 -- beyond basic blocks or over a ccall. Current max size
114 -- is 6, used in StixInteger.
118 -- Assembly-language comments
120 | StComment FAST_STRING
123 pprStixTrees :: [StixTree] -> SDoc
126 vcat (map pprStixTree ts),
131 paren t = char '(' <> t <> char ')'
133 pprStixTree :: StixTree -> SDoc
136 StSegment cseg -> paren (ppCodeSegment cseg)
137 StInt i -> paren (integer i)
138 StFloat rat -> paren (text "Float" <+> rational rat)
139 StDouble rat -> paren (text "Double" <+> rational rat)
140 StString str -> paren (text "Str" <+> ptext str)
141 StComment str -> paren (text "Comment" <+> ptext str)
142 StCLbl lbl -> pprCLabel lbl
143 StReg reg -> ppStixReg reg
144 StIndex k b o -> paren (pprStixTree b <+> char '+' <>
145 pprPrimRep k <+> pprStixTree o)
146 StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
147 StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
148 <> text " " <> pprStixTree s
149 StLabel ll -> pprCLabel ll <+> char ':'
150 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
151 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
152 StJump t -> paren (text "Jump" <+> pprStixTree t)
153 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
154 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
156 StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
157 hsep (map pprStixTree ds))
158 StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
159 hsep (map pprStixTree ts))
161 -> paren (text "Call" <+> ptext nm <+>
162 pprCallConv cc <+> pprPrimRep k <+>
163 hsep (map pprStixTree args))
164 StScratchWord i -> text "ScratchWord" <> paren (int i)
166 pprPrimRep = text . showPrimRep
169 Stix registers can have two forms. They {\em may} or {\em may not}
170 map to real, machine-level registers.
174 = StixMagicId MagicId -- Regs which are part of the abstract machine model
176 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
179 ppStixReg (StixMagicId mid)
181 ppStixReg (StixTemp u pr)
182 = hcat [text "Temp(", ppr u, ppr pr, char ')']
185 ppMId BaseReg = text "BaseReg"
186 ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
187 int (I# n), char ')']
188 ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
189 ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
190 ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
191 int (I# n), char ')']
194 ppMId SpLim = text "SpLim"
196 ppMId HpLim = text "HpLim"
197 ppMId CurCostCentre = text "CCC"
198 ppMId VoidReg = text "VoidReg"
201 We hope that every machine supports the idea of data segment and text
202 segment (or that it has no segments at all, and we can lump these
206 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
207 ppCodeSegment = text . show
209 type StixTreeList = [StixTree] -> [StixTree]
212 Stix Trees for STG registers:
214 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
217 stgBaseReg = StReg (StixMagicId BaseReg)
218 stgNode = StReg (StixMagicId node)
219 stgTagReg = StReg (StixMagicId tagreg)
220 stgSp = StReg (StixMagicId Sp)
221 stgSu = StReg (StixMagicId Su)
222 stgSpLim = StReg (StixMagicId SpLim)
223 stgHp = StReg (StixMagicId Hp)
224 stgHpLim = StReg (StixMagicId HpLim)
225 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
226 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
227 stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
228 stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
230 getNatLabelNCG :: NatM CLabel
232 = getUniqueNat `thenNat` \ u ->
233 returnNat (mkAsmTempLabel u)
235 getUniqLabelNCG :: UniqSM CLabel
237 = getUniqueUs `thenUs` \ u ->
238 returnUs (mkAsmTempLabel u)
240 fixedHS = StInt (toInteger fixedHdrSize)
241 arrWordsHS = StInt (toInteger arrWordsHdrSize)
242 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
245 Stix optimisation passes may wish to find out how many times a
246 given temporary appears in a tree, so as to be able to decide
247 whether or not to inline the assignment's RHS at usage site(s).
250 stixCountTempUses :: Unique -> StixTree -> Int
251 stixCountTempUses u t
252 = let qq = stixCountTempUses u
257 StixTemp uu pr -> if u == uu then 1 else 0
260 StIndex pk t1 t2 -> qq t1 + qq t2
262 StAssign pk t1 t2 -> qq t1 + qq t2
264 StCondJump lbl t1 -> qq t1
265 StData pk ts -> sum (map qq ts)
266 StPrim op ts -> sum (map qq ts)
267 StCall nm cconv pk ts -> sum (map qq ts)
283 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
284 stixSubst u new_u in_this_tree
285 = stixMapUniques f in_this_tree
287 f :: Unique -> Maybe StixTree
288 f uu = if uu == u then Just new_u else Nothing
291 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
293 = let qq = stixMapUniques f
304 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
305 StInd pk t1 -> StInd pk (qq t1)
306 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
307 StJump t1 -> StJump (qq t1)
308 StCondJump lbl t1 -> StCondJump lbl (qq t1)
309 StData pk ts -> StData pk (map qq ts)
310 StPrim op ts -> StPrim op (map qq ts)
311 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
328 data NatM_State = NatM_State UniqSupply Int
329 type NatM result = NatM_State -> (result, NatM_State)
331 mkNatM_State :: UniqSupply -> Int -> NatM_State
332 mkNatM_State = NatM_State
334 uniqOfNatM_State (NatM_State us delta) = us
335 deltaOfNatM_State (NatM_State us delta) = delta
338 initNat :: NatM_State -> NatM a -> (a, NatM_State)
339 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
341 thenNat :: NatM a -> (a -> NatM b) -> NatM b
343 = case expr st of { (result, st') -> cont result st' }
345 returnNat :: a -> NatM a
346 returnNat result st = (result, st)
348 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
349 mapNat f [] = returnNat []
351 = f x `thenNat` \ r ->
352 mapNat f xs `thenNat` \ rs ->
355 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
356 mapAndUnzipNat f [] = returnNat ([],[])
357 mapAndUnzipNat f (x:xs)
358 = f x `thenNat` \ (r1, r2) ->
359 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
360 returnNat (r1:rs1, r2:rs2)
362 mapAccumLNat :: (acc -> x -> NatM (acc, y))
369 mapAccumLNat f b (x:xs)
370 = f b x `thenNat` \ (b__2, x__2) ->
371 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
372 returnNat (b__3, x__2:xs__2)
375 getUniqueNat :: NatM Unique
376 getUniqueNat (NatM_State us delta)
377 = case splitUniqSupply us of
378 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
380 getDeltaNat :: NatM Int
381 getDeltaNat st@(NatM_State us delta)
384 setDeltaNat :: Int -> NatM ()
385 setDeltaNat delta (NatM_State us _)
386 = ((), NatM_State us delta)