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 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
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 may or may not jump
86 -- out of the register allocation domain (basic block, more or
87 -- less). For correct register allocation when this insn is used
88 -- to jump through a jump table, we optionally allow a list of
89 -- the exact targets to be attached, so that the allocator can
90 -- easily construct the exact flow edges leaving this insn.
91 -- Dynamic targets are allowed.
93 | StJump DestInfo StixTree
95 -- A fall-through, from slow to fast
97 | StFallThrough CLabel
99 -- A conditional jump. This instruction can be non-terminal :-)
100 -- Only static, local, forward labels are allowed
102 | StCondJump CLabel StixTree
104 -- Raw data (as in an info table).
106 | StData PrimRep [StixTree]
108 -- Primitive Operations
110 | StPrim PrimOp [StixTree]
112 -- Calls to C functions
114 | StCall FAST_STRING CallConv PrimRep [StixTree]
116 -- A volatile memory scratch array, which is allocated
117 -- relative to the stack pointer. It is an array of
118 -- ptr/word/int sized things. Do not expect to be preserved
119 -- beyond basic blocks or over a ccall. Current max size
120 -- is 6, used in StixInteger.
124 -- Assembly-language comments
126 | StComment FAST_STRING
129 -- used by insnFuture in RegAllocInfo.lhs
131 = NoDestInfo -- no supplied dests; infer from context
132 | DestInfo [CLabel] -- precisely these dests and no others
134 hasDestInfo NoDestInfo = False
135 hasDestInfo (DestInfo _) = True
137 pprDests :: DestInfo -> SDoc
138 pprDests NoDestInfo = text "NoDestInfo"
139 pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
142 pprStixTrees :: [StixTree] -> SDoc
145 vcat (map pprStixTree ts),
150 paren t = char '(' <> t <> char ')'
151 brack t = char '[' <> t <> char ']'
153 pprStixTree :: StixTree -> SDoc
156 StSegment cseg -> paren (ppCodeSegment cseg)
157 StInt i -> paren (integer i)
158 StFloat rat -> paren (text "Float" <+> rational rat)
159 StDouble rat -> paren (text "Double" <+> rational rat)
160 StString str -> paren (text "Str" <+> ptext str)
161 StComment str -> paren (text "Comment" <+> ptext str)
162 StCLbl lbl -> pprCLabel lbl
163 StReg reg -> ppStixReg reg
164 StIndex k b o -> paren (pprStixTree b <+> char '+' <>
165 pprPrimRep k <+> pprStixTree o)
166 StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
167 StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
168 <> text " " <> pprStixTree s
169 StLabel ll -> pprCLabel ll <+> char ':'
170 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
171 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
172 StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
173 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
174 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
176 StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
177 hsep (map pprStixTree ds))
178 StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
179 hsep (map pprStixTree ts))
181 -> paren (text "Call" <+> ptext nm <+>
182 pprCallConv cc <+> pprPrimRep k <+>
183 hsep (map pprStixTree args))
184 StScratchWord i -> text "ScratchWord" <> paren (int i)
186 pprPrimRep = text . showPrimRep
189 Stix registers can have two forms. They {\em may} or {\em may not}
190 map to real, machine-level registers.
194 = StixMagicId MagicId -- Regs which are part of the abstract machine model
196 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
199 ppStixReg (StixMagicId mid)
201 ppStixReg (StixTemp u pr)
202 = hcat [text "Temp(", ppr u, ppr pr, char ')']
205 ppMId BaseReg = text "BaseReg"
206 ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
207 int (I# n), char ')']
208 ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
209 ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
210 ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
211 int (I# n), char ')']
214 ppMId SpLim = text "SpLim"
216 ppMId HpLim = text "HpLim"
217 ppMId CurCostCentre = text "CCC"
218 ppMId VoidReg = text "VoidReg"
221 We hope that every machine supports the idea of data segment and text
222 segment (or that it has no segments at all, and we can lump these
226 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
227 ppCodeSegment = text . show
229 type StixTreeList = [StixTree] -> [StixTree]
232 Stix Trees for STG registers:
234 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
237 stgBaseReg = StReg (StixMagicId BaseReg)
238 stgNode = StReg (StixMagicId node)
239 stgTagReg = StReg (StixMagicId tagreg)
240 stgSp = StReg (StixMagicId Sp)
241 stgSu = StReg (StixMagicId Su)
242 stgSpLim = StReg (StixMagicId SpLim)
243 stgHp = StReg (StixMagicId Hp)
244 stgHpLim = StReg (StixMagicId HpLim)
245 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
246 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
247 stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
248 stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
250 getNatLabelNCG :: NatM CLabel
252 = getUniqueNat `thenNat` \ u ->
253 returnNat (mkAsmTempLabel u)
255 getUniqLabelNCG :: UniqSM CLabel
257 = getUniqueUs `thenUs` \ u ->
258 returnUs (mkAsmTempLabel u)
260 fixedHS = StInt (toInteger fixedHdrSize)
261 arrWordsHS = StInt (toInteger arrWordsHdrSize)
262 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
265 Stix optimisation passes may wish to find out how many times a
266 given temporary appears in a tree, so as to be able to decide
267 whether or not to inline the assignment's RHS at usage site(s).
270 stixCountTempUses :: Unique -> StixTree -> Int
271 stixCountTempUses u t
272 = let qq = stixCountTempUses u
277 StixTemp uu pr -> if u == uu then 1 else 0
280 StIndex pk t1 t2 -> qq t1 + qq t2
282 StAssign pk t1 t2 -> qq t1 + qq t2
283 StJump dsts t1 -> qq t1
284 StCondJump lbl t1 -> qq t1
285 StData pk ts -> sum (map qq ts)
286 StPrim op ts -> sum (map qq ts)
287 StCall nm cconv pk ts -> sum (map qq ts)
303 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
304 stixSubst u new_u in_this_tree
305 = stixMapUniques f in_this_tree
307 f :: Unique -> Maybe StixTree
308 f uu = if uu == u then Just new_u else Nothing
311 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
313 = let qq = stixMapUniques f
324 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
325 StInd pk t1 -> StInd pk (qq t1)
326 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
327 StJump dsts t1 -> StJump dsts (qq t1)
328 StCondJump lbl t1 -> StCondJump lbl (qq t1)
329 StData pk ts -> StData pk (map qq ts)
330 StPrim op ts -> StPrim op (map qq ts)
331 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
348 data NatM_State = NatM_State UniqSupply Int
349 type NatM result = NatM_State -> (result, NatM_State)
351 mkNatM_State :: UniqSupply -> Int -> NatM_State
352 mkNatM_State = NatM_State
354 uniqOfNatM_State (NatM_State us delta) = us
355 deltaOfNatM_State (NatM_State us delta) = delta
358 initNat :: NatM_State -> NatM a -> (a, NatM_State)
359 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
361 thenNat :: NatM a -> (a -> NatM b) -> NatM b
363 = case expr st of { (result, st') -> cont result st' }
365 returnNat :: a -> NatM a
366 returnNat result st = (result, st)
368 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
369 mapNat f [] = returnNat []
371 = f x `thenNat` \ r ->
372 mapNat f xs `thenNat` \ rs ->
375 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
376 mapAndUnzipNat f [] = returnNat ([],[])
377 mapAndUnzipNat f (x:xs)
378 = f x `thenNat` \ (r1, r2) ->
379 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
380 returnNat (r1:rs1, r2:rs2)
382 mapAccumLNat :: (acc -> x -> NatM (acc, y))
389 mapAccumLNat f b (x:xs)
390 = f b x `thenNat` \ (b__2, x__2) ->
391 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
392 returnNat (b__3, x__2:xs__2)
395 getUniqueNat :: NatM Unique
396 getUniqueNat (NatM_State us delta)
397 = case splitUniqSupply us of
398 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
400 getDeltaNat :: NatM Int
401 getDeltaNat st@(NatM_State us delta)
404 setDeltaNat :: Int -> NatM ()
405 setDeltaNat delta (NatM_State us _)
406 = ((), NatM_State us delta)