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
57 | StString FAST_STRING
58 | StCLbl CLabel -- labels that we might index into
60 -- Abstract registers of various kinds
64 -- A typed offset from a base location
66 | StIndex PrimRep StixTree StixTree -- kind, base, offset
68 -- An indirection from an address to its contents.
70 | StInd PrimRep StixTree
72 -- Assignment is typed to determine size and register placement
74 | StAssign PrimRep StixTree StixTree -- dst, src
76 -- A simple assembly label that we might jump to.
80 -- A function header and footer
85 -- An unconditional jump. This instruction is terminal.
86 -- Dynamic targets are allowed
90 -- A fall-through, from slow to fast
92 | StFallThrough CLabel
94 -- A conditional jump. This instruction can be non-terminal :-)
95 -- Only static, local, forward labels are allowed
97 | StCondJump CLabel StixTree
99 -- Raw data (as in an info table).
101 | StData PrimRep [StixTree]
103 -- Primitive Operations
105 | StPrim PrimOp [StixTree]
107 -- Calls to C functions
109 | StCall FAST_STRING CallConv PrimRep [StixTree]
111 -- A volatile memory scratch array, which is allocated
112 -- relative to the stack pointer. It is an array of
113 -- ptr/word/int sized things. Do not expect to be preserved
114 -- beyond basic blocks or over a ccall. Current max size
115 -- is 6, used in StixInteger.
119 -- Assembly-language comments
121 | StComment FAST_STRING
124 pprStixTrees :: [StixTree] -> SDoc
127 vcat (map pprStixTree ts),
132 paren t = char '(' <> t <> char ')'
134 pprStixTree :: StixTree -> SDoc
137 StSegment cseg -> paren (ppCodeSegment cseg)
138 StInt i -> paren (integer i)
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)
282 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
283 stixSubst u new_u in_this_tree
284 = stixMapUniques f in_this_tree
286 f :: Unique -> Maybe StixTree
287 f uu = if uu == u then Just new_u else Nothing
290 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
292 = let qq = stixMapUniques f
303 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
304 StInd pk t1 -> StInd pk (qq t1)
305 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
306 StJump t1 -> StJump (qq t1)
307 StCondJump lbl t1 -> StCondJump lbl (qq t1)
308 StData pk ts -> StData pk (map qq ts)
309 StPrim op ts -> StPrim op (map qq ts)
310 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
326 data NatM_State = NatM_State UniqSupply Int
327 type NatM result = NatM_State -> (result, NatM_State)
329 mkNatM_State :: UniqSupply -> Int -> NatM_State
330 mkNatM_State = NatM_State
332 uniqOfNatM_State (NatM_State us delta) = us
333 deltaOfNatM_State (NatM_State us delta) = delta
336 initNat :: NatM_State -> NatM a -> (a, NatM_State)
337 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
339 thenNat :: NatM a -> (a -> NatM b) -> NatM b
341 = case expr st of { (result, st') -> cont result st' }
343 returnNat :: a -> NatM a
344 returnNat result st = (result, st)
346 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
347 mapNat f [] = returnNat []
349 = f x `thenNat` \ r ->
350 mapNat f xs `thenNat` \ rs ->
353 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
354 mapAndUnzipNat f [] = returnNat ([],[])
355 mapAndUnzipNat f (x:xs)
356 = f x `thenNat` \ (r1, r2) ->
357 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
358 returnNat (r1:rs1, r2:rs2)
360 mapAccumLNat :: (acc -> x -> NatM (acc, y))
367 mapAccumLNat f b (x:xs)
368 = f b x `thenNat` \ (b__2, x__2) ->
369 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
370 returnNat (b__3, x__2:xs__2)
373 getUniqueNat :: NatM Unique
374 getUniqueNat (NatM_State us delta)
375 = case splitUniqSupply us of
376 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
378 getDeltaNat :: NatM Int
379 getDeltaNat st@(NatM_State us delta)
382 setDeltaNat :: Int -> NatM ()
383 setDeltaNat delta (NatM_State us _)
384 = ((), NatM_State us delta)