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 AbsCUtils ( magicIdPrimRep )
32 import CallConv ( CallConv, pprCallConv )
33 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm )
34 import PrimRep ( PrimRep(..), showPrimRep )
35 import PrimOp ( PrimOp, pprPrimOp )
36 import Unique ( Unique )
37 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
38 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
39 UniqSM, thenUs, returnUs, getUniqueUs )
40 import CmdLineOpts ( opt_Static )
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 is terminal.
87 -- Dynamic targets are allowed
91 -- A fall-through, from slow to fast
93 | StFallThrough CLabel
95 -- A conditional jump. This instruction can be non-terminal :-)
96 -- Only static, local, forward labels are allowed
98 | StCondJump CLabel StixTree
100 -- Raw data (as in an info table).
102 | StData PrimRep [StixTree]
104 -- Primitive Operations
106 | StPrim PrimOp [StixTree]
108 -- Calls to C functions
110 | StCall FAST_STRING CallConv PrimRep [StixTree]
112 -- A volatile memory scratch array, which is allocated
113 -- relative to the stack pointer. It is an array of
114 -- ptr/word/int sized things. Do not expect to be preserved
115 -- beyond basic blocks or over a ccall. Current max size
116 -- is 6, used in StixInteger.
120 -- Assembly-language comments
122 | StComment FAST_STRING
125 pprStixTrees :: [StixTree] -> SDoc
128 vcat (map pprStixTree ts),
133 paren t = char '(' <> t <> char ')'
135 pprStixTree :: StixTree -> SDoc
138 StSegment cseg -> paren (ppCodeSegment cseg)
139 StInt i -> paren (integer i)
140 StFloat rat -> paren (text "Float" <+> rational rat)
141 StDouble rat -> paren (text "Double" <+> rational rat)
142 StString str -> paren (text "Str" <+> ptext str)
143 StComment str -> paren (text "Comment" <+> ptext str)
144 StCLbl lbl -> pprCLabel lbl
145 StReg reg -> ppStixReg reg
146 StIndex k b o -> paren (pprStixTree b <+> char '+' <>
147 pprPrimRep k <+> pprStixTree o)
148 StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
149 StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
150 <> text " " <> pprStixTree s
151 StLabel ll -> pprCLabel ll <+> char ':'
152 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
153 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
154 StJump t -> paren (text "Jump" <+> pprStixTree t)
155 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
156 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
158 StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
159 hsep (map pprStixTree ds))
160 StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
161 hsep (map pprStixTree ts))
163 -> paren (text "Call" <+> ptext nm <+>
164 pprCallConv cc <+> pprPrimRep k <+>
165 hsep (map pprStixTree args))
166 StScratchWord i -> text "ScratchWord" <> paren (int i)
168 pprPrimRep = text . showPrimRep
171 Stix registers can have two forms. They {\em may} or {\em may not}
172 map to real, machine-level registers.
176 = StixMagicId MagicId -- Regs which are part of the abstract machine model
178 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
181 ppStixReg (StixMagicId mid)
183 ppStixReg (StixTemp u pr)
184 = hcat [text "Temp(", ppr u, ppr pr, char ')']
187 ppMId BaseReg = text "BaseReg"
188 ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
189 int (I# n), char ')']
190 ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
191 ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
192 ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
193 int (I# n), char ')']
196 ppMId SpLim = text "SpLim"
198 ppMId HpLim = text "HpLim"
199 ppMId CurCostCentre = text "CCC"
200 ppMId VoidReg = text "VoidReg"
203 We hope that every machine supports the idea of data segment and text
204 segment (or that it has no segments at all, and we can lump these
208 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
209 ppCodeSegment = text . show
211 type StixTreeList = [StixTree] -> [StixTree]
214 Stix Trees for STG registers:
216 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
219 stgBaseReg = StReg (StixMagicId BaseReg)
220 stgNode = StReg (StixMagicId node)
221 stgTagReg = StReg (StixMagicId tagreg)
222 stgSp = StReg (StixMagicId Sp)
223 stgSu = StReg (StixMagicId Su)
224 stgSpLim = StReg (StixMagicId SpLim)
225 stgHp = StReg (StixMagicId Hp)
226 stgHpLim = StReg (StixMagicId HpLim)
227 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
228 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
229 stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
230 stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
232 getNatLabelNCG :: NatM CLabel
234 = getUniqueNat `thenNat` \ u ->
235 returnNat (mkAsmTempLabel u)
237 getUniqLabelNCG :: UniqSM CLabel
239 = getUniqueUs `thenUs` \ u ->
240 returnUs (mkAsmTempLabel u)
242 fixedHS = StInt (toInteger fixedHdrSize)
243 arrWordsHS = StInt (toInteger arrWordsHdrSize)
244 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
247 Stix optimisation passes may wish to find out how many times a
248 given temporary appears in a tree, so as to be able to decide
249 whether or not to inline the assignment's RHS at usage site(s).
252 stixCountTempUses :: Unique -> StixTree -> Int
253 stixCountTempUses u t
254 = let qq = stixCountTempUses u
259 StixTemp uu pr -> if u == uu then 1 else 0
262 StIndex pk t1 t2 -> qq t1 + qq t2
264 StAssign pk t1 t2 -> qq t1 + qq t2
266 StCondJump lbl t1 -> qq t1
267 StData pk ts -> sum (map qq ts)
268 StPrim op ts -> sum (map qq ts)
269 StCall nm cconv pk ts -> sum (map qq ts)
285 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
286 stixSubst u new_u in_this_tree
287 = stixMapUniques f in_this_tree
289 f :: Unique -> Maybe StixTree
290 f uu = if uu == u then Just new_u else Nothing
293 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
295 = let qq = stixMapUniques f
306 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
307 StInd pk t1 -> StInd pk (qq t1)
308 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
309 StJump t1 -> StJump (qq t1)
310 StCondJump lbl t1 -> StCondJump lbl (qq t1)
311 StData pk ts -> StData pk (map qq ts)
312 StPrim op ts -> StPrim op (map qq ts)
313 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
330 data NatM_State = NatM_State UniqSupply Int
331 type NatM result = NatM_State -> (result, NatM_State)
333 mkNatM_State :: UniqSupply -> Int -> NatM_State
334 mkNatM_State = NatM_State
336 uniqOfNatM_State (NatM_State us delta) = us
337 deltaOfNatM_State (NatM_State us delta) = delta
340 initNat :: NatM_State -> NatM a -> (a, NatM_State)
341 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
343 thenNat :: NatM a -> (a -> NatM b) -> NatM b
345 = case expr st of { (result, st') -> cont result st' }
347 returnNat :: a -> NatM a
348 returnNat result st = (result, st)
350 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
351 mapNat f [] = returnNat []
353 = f x `thenNat` \ r ->
354 mapNat f xs `thenNat` \ rs ->
357 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
358 mapAndUnzipNat f [] = returnNat ([],[])
359 mapAndUnzipNat f (x:xs)
360 = f x `thenNat` \ (r1, r2) ->
361 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
362 returnNat (r1:rs1, r2:rs2)
364 mapAccumLNat :: (acc -> x -> NatM (acc, y))
371 mapAccumLNat f b (x:xs)
372 = f b x `thenNat` \ (b__2, x__2) ->
373 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
374 returnNat (b__3, x__2:xs__2)
377 getUniqueNat :: NatM Unique
378 getUniqueNat (NatM_State us delta)
379 = case splitUniqSupply us of
380 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
382 getDeltaNat :: NatM Int
383 getDeltaNat st@(NatM_State us delta)
386 setDeltaNat :: Int -> NatM ()
387 setDeltaNat delta (NatM_State us _)
388 = ((), NatM_State us delta)