2 % (c) The AQUA Project, Glasgow University, 1993-1998
7 CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
8 sStLitLbl, pprStixTrees, ppStixTree, 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 )
43 Here is the tag at the nodes of our @StixTree@. Notice its
44 relationship with @PrimOp@ in prelude/PrimOp.
48 = -- Segment (text or data)
52 -- We can tag the leaves with constants/immediates.
54 | StInt Integer -- ** add Kind at some point
56 | StString FAST_STRING
57 | StLitLbl SDoc -- literal labels
58 -- (will be _-prefixed on some machines)
60 | StCLbl CLabel -- labels that we might index into
62 -- Abstract registers of various kinds
66 -- A typed offset from a base location
68 | StIndex PrimRep StixTree StixTree -- kind, base, offset
70 -- An indirection from an address to its contents.
72 | StInd PrimRep StixTree
74 -- Assignment is typed to determine size and register placement
76 | StAssign PrimRep StixTree StixTree -- dst, src
78 -- A simple assembly label that we might jump to.
82 -- A function header and footer
87 -- An unconditional jump. This instruction is terminal.
88 -- Dynamic targets are allowed
92 -- A fall-through, from slow to fast
94 | StFallThrough CLabel
96 -- A conditional jump. This instruction can be non-terminal :-)
97 -- Only static, local, forward labels are allowed
99 | StCondJump CLabel StixTree
101 -- Raw data (as in an info table).
103 | StData PrimRep [StixTree]
105 -- Primitive Operations
107 | StPrim PrimOp [StixTree]
109 -- Calls to C functions
111 | StCall FAST_STRING CallConv PrimRep [StixTree]
113 -- A volatile memory scratch array, which is allocated
114 -- relative to the stack pointer. It is an array of
115 -- ptr/word/int sized things. Do not expect to be preserved
116 -- beyond basic blocks or over a ccall. Current max size
117 -- is 6, used in StixInteger.
121 -- Assembly-language comments
123 | StComment FAST_STRING
125 sStLitLbl :: FAST_STRING -> StixTree
126 sStLitLbl s = StLitLbl (ptext s)
129 pprStixTrees :: [StixTree] -> SDoc
132 vcat (map ppStixTree ts),
137 paren t = char '(' <> t <> char ')'
139 ppStixTree :: StixTree -> SDoc
142 StSegment cseg -> paren (ppCodeSegment cseg)
143 StInt i -> paren (integer i)
144 StDouble rat -> paren (text "Double" <+> rational rat)
145 StString str -> paren (text "Str" <+> ptext str)
146 StComment str -> paren (text "Comment" <+> ptext str)
148 StCLbl lbl -> pprCLabel lbl
149 StReg reg -> ppStixReg reg
150 StIndex k b o -> paren (ppStixTree b <+> char '+' <>
151 pprPrimRep k <+> ppStixTree o)
152 StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']'
153 StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k
154 <> text " " <> ppStixTree s
155 StLabel ll -> pprCLabel ll <+> char ':'
156 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
157 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
158 StJump t -> paren (text "Jump" <+> ppStixTree t)
159 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
160 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
162 StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
163 hsep (map ppStixTree ds))
164 StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
165 hsep (map ppStixTree ts))
167 -> paren (text "Call" <+> ptext nm <+>
168 pprCallConv cc <+> pprPrimRep k <+>
169 hsep (map ppStixTree args))
170 StScratchWord i -> text "ScratchWord" <> paren (int i)
172 pprPrimRep = text . showPrimRep
175 Stix registers can have two forms. They {\em may} or {\em may not}
176 map to real, machine-level registers.
180 = StixMagicId MagicId -- Regs which are part of the abstract machine model
182 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
185 ppStixReg (StixMagicId mid)
187 ppStixReg (StixTemp u pr)
188 = hcat [text "Temp(", ppr u, ppr pr, char ')']
191 ppMId BaseReg = text "BaseReg"
192 ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
193 int (I# n), char ')']
194 ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
195 ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
196 ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
197 int (I# n), char ')']
200 ppMId SpLim = text "SpLim"
202 ppMId HpLim = text "HpLim"
203 ppMId CurCostCentre = text "CCC"
204 ppMId VoidReg = text "VoidReg"
207 We hope that every machine supports the idea of data segment and text
208 segment (or that it has no segments at all, and we can lump these
212 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
213 ppCodeSegment = text . show
215 type StixTreeList = [StixTree] -> [StixTree]
218 Stix Trees for STG registers:
220 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
223 stgBaseReg = StReg (StixMagicId BaseReg)
224 stgNode = StReg (StixMagicId node)
225 stgTagReg = StReg (StixMagicId tagreg)
226 stgSp = StReg (StixMagicId Sp)
227 stgSu = StReg (StixMagicId Su)
228 stgSpLim = StReg (StixMagicId SpLim)
229 stgHp = StReg (StixMagicId Hp)
230 stgHpLim = StReg (StixMagicId HpLim)
231 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
232 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
233 stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
234 stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
236 getNatLabelNCG :: NatM CLabel
238 = getUniqueNat `thenNat` \ u ->
239 returnNat (mkAsmTempLabel u)
241 getUniqLabelNCG :: UniqSM CLabel
243 = getUniqueUs `thenUs` \ u ->
244 returnUs (mkAsmTempLabel u)
246 fixedHS = StInt (toInteger fixedHdrSize)
247 arrWordsHS = StInt (toInteger arrWordsHdrSize)
248 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
251 Stix optimisation passes may wish to find out how many times a
252 given temporary appears in a tree, so as to be able to decide
253 whether or not to inline the assignment's RHS at usage site(s).
256 stixCountTempUses :: Unique -> StixTree -> Int
257 stixCountTempUses u t
258 = let qq = stixCountTempUses u
263 StixTemp uu pr -> if u == uu then 1 else 0
266 StIndex pk t1 t2 -> qq t1 + qq t2
268 StAssign pk t1 t2 -> qq t1 + qq t2
270 StCondJump lbl t1 -> qq t1
271 StData pk ts -> sum (map qq ts)
272 StPrim op ts -> sum (map qq ts)
273 StCall nm cconv pk ts -> sum (map qq ts)
289 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
290 stixSubst u new_u in_this_tree
291 = stixMapUniques f in_this_tree
293 f :: Unique -> Maybe StixTree
294 f uu = if uu == u then Just new_u else Nothing
297 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
299 = let qq = stixMapUniques f
310 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
311 StInd pk t1 -> StInd pk (qq t1)
312 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
313 StJump t1 -> StJump (qq t1)
314 StCondJump lbl t1 -> StCondJump lbl (qq t1)
315 StData pk ts -> StData pk (map qq ts)
316 StPrim op ts -> StPrim op (map qq ts)
317 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
334 data NatM_State = NatM_State UniqSupply Int
335 type NatM result = NatM_State -> (result, NatM_State)
337 mkNatM_State :: UniqSupply -> Int -> NatM_State
338 mkNatM_State = NatM_State
340 uniqOfNatM_State (NatM_State us delta) = us
341 deltaOfNatM_State (NatM_State us delta) = delta
344 initNat :: NatM_State -> NatM a -> (a, NatM_State)
345 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
347 thenNat :: NatM a -> (a -> NatM b) -> NatM b
349 = case expr st of { (result, st') -> cont result st' }
351 returnNat :: a -> NatM a
352 returnNat result st = (result, st)
354 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
355 mapNat f [] = returnNat []
357 = f x `thenNat` \ r ->
358 mapNat f xs `thenNat` \ rs ->
361 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
362 mapAndUnzipNat f [] = returnNat ([],[])
363 mapAndUnzipNat f (x:xs)
364 = f x `thenNat` \ (r1, r2) ->
365 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
366 returnNat (r1:rs1, r2:rs2)
368 mapAccumLNat :: (acc -> x -> NatM (acc, y))
375 mapAccumLNat f b (x:xs)
376 = f b x `thenNat` \ (b__2, x__2) ->
377 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
378 returnNat (b__3, x__2:xs__2)
381 getUniqueNat :: NatM Unique
382 getUniqueNat (NatM_State us delta)
383 = case splitUniqSupply us of
384 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
386 getDeltaNat :: NatM Int
387 getDeltaNat st@(NatM_State us delta)
390 setDeltaNat :: Int -> NatM ()
391 setDeltaNat delta (NatM_State us _)
392 = ((), NatM_State us delta)