2 % (c) The AQUA Project, Glasgow University, 1993-1998
7 CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
8 pprStixTrees, pprStixTree, ppStixReg,
9 stixCountTempUses, stixSubst,
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 pprDests :: DestInfo -> SDoc
135 pprDests NoDestInfo = text "NoDestInfo"
136 pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
139 pprStixTrees :: [StixTree] -> SDoc
142 vcat (map pprStixTree ts),
147 paren t = char '(' <> t <> char ')'
148 brack t = char '[' <> t <> char ']'
150 pprStixTree :: StixTree -> SDoc
153 StSegment cseg -> paren (ppCodeSegment cseg)
154 StInt i -> paren (integer i)
155 StFloat rat -> paren (text "Float" <+> rational rat)
156 StDouble rat -> paren (text "Double" <+> rational rat)
157 StString str -> paren (text "Str" <+> ptext str)
158 StComment str -> paren (text "Comment" <+> ptext str)
159 StCLbl lbl -> pprCLabel lbl
160 StReg reg -> ppStixReg reg
161 StIndex k b o -> paren (pprStixTree b <+> char '+' <>
162 pprPrimRep k <+> pprStixTree o)
163 StInd k t -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
164 StAssign k d s -> pprStixTree d <> text " :=" <> pprPrimRep k
165 <> text " " <> pprStixTree s
166 StLabel ll -> pprCLabel ll <+> char ':'
167 StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
168 StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
169 StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
170 StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
171 StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
173 StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
174 hsep (map pprStixTree ds))
175 StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+>
176 hsep (map pprStixTree ts))
178 -> paren (text "Call" <+> ptext nm <+>
179 pprCallConv cc <+> pprPrimRep k <+>
180 hsep (map pprStixTree args))
181 StScratchWord i -> text "ScratchWord" <> paren (int i)
183 pprPrimRep = text . showPrimRep
186 Stix registers can have two forms. They {\em may} or {\em may not}
187 map to real, machine-level registers.
191 = StixMagicId MagicId -- Regs which are part of the abstract machine model
193 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
196 ppStixReg (StixMagicId mid)
198 ppStixReg (StixTemp u pr)
199 = hcat [text "Temp(", ppr u, ppr pr, char ')']
202 ppMId BaseReg = text "BaseReg"
203 ppMId (VanillaReg kind n) = hcat [pprPrimRep kind, text "IntReg(",
204 int (I# n), char ')']
205 ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')']
206 ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')']
207 ppMId (LongReg kind n) = hcat [pprPrimRep kind, text "LongReg(",
208 int (I# n), char ')']
211 ppMId SpLim = text "SpLim"
213 ppMId HpLim = text "HpLim"
214 ppMId CurCostCentre = text "CCC"
215 ppMId VoidReg = text "VoidReg"
218 We hope that every machine supports the idea of data segment and text
219 segment (or that it has no segments at all, and we can lump these
223 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
224 ppCodeSegment = text . show
226 type StixTreeList = [StixTree] -> [StixTree]
229 Stix Trees for STG registers:
231 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
234 stgBaseReg = StReg (StixMagicId BaseReg)
235 stgNode = StReg (StixMagicId node)
236 stgTagReg = StReg (StixMagicId tagreg)
237 stgSp = StReg (StixMagicId Sp)
238 stgSu = StReg (StixMagicId Su)
239 stgSpLim = StReg (StixMagicId SpLim)
240 stgHp = StReg (StixMagicId Hp)
241 stgHpLim = StReg (StixMagicId HpLim)
242 stgCurrentTSO = StReg (StixMagicId CurrentTSO)
243 stgCurrentNursery = StReg (StixMagicId CurrentNursery)
244 stgR9 = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
245 stgR10 = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
247 getNatLabelNCG :: NatM CLabel
249 = getUniqueNat `thenNat` \ u ->
250 returnNat (mkAsmTempLabel u)
252 getUniqLabelNCG :: UniqSM CLabel
254 = getUniqueUs `thenUs` \ u ->
255 returnUs (mkAsmTempLabel u)
257 fixedHS = StInt (toInteger fixedHdrSize)
258 arrWordsHS = StInt (toInteger arrWordsHdrSize)
259 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
262 Stix optimisation passes may wish to find out how many times a
263 given temporary appears in a tree, so as to be able to decide
264 whether or not to inline the assignment's RHS at usage site(s).
267 stixCountTempUses :: Unique -> StixTree -> Int
268 stixCountTempUses u t
269 = let qq = stixCountTempUses u
274 StixTemp uu pr -> if u == uu then 1 else 0
277 StIndex pk t1 t2 -> qq t1 + qq t2
279 StAssign pk t1 t2 -> qq t1 + qq t2
280 StJump dsts t1 -> qq t1
281 StCondJump lbl t1 -> qq t1
282 StData pk ts -> sum (map qq ts)
283 StPrim op ts -> sum (map qq ts)
284 StCall nm cconv pk ts -> sum (map qq ts)
300 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
301 stixSubst u new_u in_this_tree
302 = stixMapUniques f in_this_tree
304 f :: Unique -> Maybe StixTree
305 f uu = if uu == u then Just new_u else Nothing
308 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
310 = let qq = stixMapUniques f
321 StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
322 StInd pk t1 -> StInd pk (qq t1)
323 StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
324 StJump dsts t1 -> StJump dsts (qq t1)
325 StCondJump lbl t1 -> StCondJump lbl (qq t1)
326 StData pk ts -> StData pk (map qq ts)
327 StPrim op ts -> StPrim op (map qq ts)
328 StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts)
345 data NatM_State = NatM_State UniqSupply Int
346 type NatM result = NatM_State -> (result, NatM_State)
348 mkNatM_State :: UniqSupply -> Int -> NatM_State
349 mkNatM_State = NatM_State
351 uniqOfNatM_State (NatM_State us delta) = us
352 deltaOfNatM_State (NatM_State us delta) = delta
355 initNat :: NatM_State -> NatM a -> (a, NatM_State)
356 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
358 thenNat :: NatM a -> (a -> NatM b) -> NatM b
360 = case expr st of { (result, st') -> cont result st' }
362 returnNat :: a -> NatM a
363 returnNat result st = (result, st)
365 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
366 mapNat f [] = returnNat []
368 = f x `thenNat` \ r ->
369 mapNat f xs `thenNat` \ rs ->
372 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
373 mapAndUnzipNat f [] = returnNat ([],[])
374 mapAndUnzipNat f (x:xs)
375 = f x `thenNat` \ (r1, r2) ->
376 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
377 returnNat (r1:rs1, r2:rs2)
379 mapAccumLNat :: (acc -> x -> NatM (acc, y))
386 mapAccumLNat f b (x:xs)
387 = f b x `thenNat` \ (b__2, x__2) ->
388 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
389 returnNat (b__3, x__2:xs__2)
392 getUniqueNat :: NatM Unique
393 getUniqueNat (NatM_State us delta)
394 = case splitUniqSupply us of
395 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
397 getDeltaNat :: NatM Int
398 getDeltaNat st@(NatM_State us delta)
401 setDeltaNat :: Int -> NatM ()
402 setDeltaNat delta (NatM_State us _)
403 = ((), NatM_State us delta)