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, stgHpAlloc, 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,
28 #include "HsVersions.h"
30 import Ratio ( Rational )
31 import IOExts ( unsafePerformIO )
32 import IO ( hPutStrLn, stderr )
34 import AbsCSyn ( node, tagreg, MagicId(..) )
35 import ForeignCall ( CCallConv )
36 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
37 import PrimRep ( PrimRep(..) )
38 import PrimOp ( PrimOp )
39 import Unique ( Unique )
40 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
41 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
42 UniqSM, thenUs, returnUs, getUniqueUs )
47 Here is the tag at the nodes of our @StixTree@. Notice its
48 relationship with @PrimOp@ in prelude/PrimOp.
52 = -- Segment (text or data)
56 -- We can tag the leaves with constants/immediates.
58 | StInt Integer -- ** add Kind at some point
61 | StString FAST_STRING
62 | StCLbl CLabel -- labels that we might index into
64 -- Abstract registers of various kinds
68 -- A typed offset from a base location
70 | StIndex PrimRep StixTree StixTree -- kind, base, offset
72 -- An indirection from an address to its contents.
74 | StInd PrimRep StixTree
76 -- Assignment is typed to determine size and register placement
78 | StAssign PrimRep StixTree StixTree -- dst, src
80 -- A simple assembly label that we might jump to.
84 -- A function header and footer
89 -- An unconditional jump. This instruction may or may not jump
90 -- out of the register allocation domain (basic block, more or
91 -- less). For correct register allocation when this insn is used
92 -- to jump through a jump table, we optionally allow a list of
93 -- the exact targets to be attached, so that the allocator can
94 -- easily construct the exact flow edges leaving this insn.
95 -- Dynamic targets are allowed.
97 | StJump DestInfo StixTree
99 -- A fall-through, from slow to fast
101 | StFallThrough CLabel
103 -- A conditional jump. This instruction can be non-terminal :-)
104 -- Only static, local, forward labels are allowed
106 | StCondJump CLabel StixTree
108 -- Raw data (as in an info table).
110 | StData PrimRep [StixTree]
112 -- Primitive Operations
114 | StPrim PrimOp [StixTree]
116 -- Calls to C functions
118 | StCall FAST_STRING CCallConv PrimRep [StixTree]
120 -- A volatile memory scratch array, which is allocated
121 -- relative to the stack pointer. It is an array of
122 -- ptr/word/int sized things. Do not expect to be preserved
123 -- beyond basic blocks or over a ccall. Current max size
124 -- is 6, used in StixInteger.
128 -- Assembly-language comments
130 | StComment FAST_STRING
133 -- used by insnFuture in RegAllocInfo.lhs
135 = NoDestInfo -- no supplied dests; infer from context
136 | DestInfo [CLabel] -- precisely these dests and no others
138 hasDestInfo NoDestInfo = False
139 hasDestInfo (DestInfo _) = True
141 pprDests :: DestInfo -> SDoc
142 pprDests NoDestInfo = text "NoDestInfo"
143 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
146 pprStixTrees :: [StixTree] -> SDoc
149 vcat (map pprStixTree ts),
154 pprStixTree :: StixTree -> SDoc
157 StSegment cseg -> parens (ppCodeSegment cseg)
158 StInt i -> parens (integer i)
159 StFloat rat -> parens (text "Float" <+> rational rat)
160 StDouble rat -> parens (text "Double" <+> rational rat)
161 StString str -> parens (text "Str `" <> ptext str <> char '\'')
162 StComment str -> parens (text "Comment" <+> ptext str)
163 StCLbl lbl -> pprCLabel lbl
164 StReg reg -> ppStixReg reg
165 StIndex k b o -> parens (pprStixTree b <+> char '+' <>
166 ppr k <+> pprStixTree o)
167 StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']'
168 StAssign k d s -> pprStixTree d <> text " :=" <> ppr k
169 <> text " " <> pprStixTree s
170 StLabel ll -> pprCLabel ll <+> char ':'
171 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
172 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
173 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixTree t)
174 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
175 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
177 StData k ds -> parens (text "Data" <+> ppr k <+>
178 hsep (map pprStixTree ds))
179 StPrim op ts -> parens (text "Prim" <+> ppr op <+>
180 hsep (map pprStixTree ts))
182 -> parens (text "Call" <+> ptext nm <+>
184 hsep (map pprStixTree args))
185 StScratchWord i -> text "ScratchWord" <> parens (int i)
188 Stix registers can have two forms. They {\em may} or {\em may not}
189 map to real, machine-level registers.
193 = StixMagicId MagicId -- Regs which are part of the abstract machine model
195 | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
198 ppStixReg (StixMagicId mid)
200 ppStixReg (StixTemp u pr)
201 = hcat [text "Temp(", ppr u, ppr pr, char ')']
204 ppMId BaseReg = text "BaseReg"
205 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
206 int (iBox n), char ')']
207 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
208 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
209 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
210 int (iBox n), char ')']
213 ppMId SpLim = text "SpLim"
215 ppMId HpLim = text "HpLim"
216 ppMId CurCostCentre = text "CCC"
217 ppMId VoidReg = text "VoidReg"
220 We hope that every machine supports the idea of data segment and text
221 segment (or that it has no segments at all, and we can lump these
225 data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
226 ppCodeSegment = text . show
228 type StixTreeList = [StixTree] -> [StixTree]
231 Stix Trees for STG registers:
233 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
236 stgBaseReg = StReg (StixMagicId BaseReg)
237 stgNode = StReg (StixMagicId node)
238 stgTagReg = StReg (StixMagicId tagreg)
239 stgSp = StReg (StixMagicId Sp)
240 stgSu = StReg (StixMagicId Su)
241 stgSpLim = StReg (StixMagicId SpLim)
242 stgHp = StReg (StixMagicId Hp)
243 stgHpLim = StReg (StixMagicId HpLim)
244 stgHpAlloc = StReg (StixMagicId HpAlloc)
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)
409 Giving up in a not-too-inelegant way.
412 ncgPrimopMoan :: String -> SDoc -> a
413 ncgPrimopMoan msg pp_rep
417 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
418 "machinery. You can work around this for the time being by compiling\n" ++
419 "this module via the C route, by giving the flag -fvia-C.\n" ++
420 "The panic below contains information, intended for the GHC implementors,\n" ++
421 "about the exact place where GHC gave up. Please send it to us\n" ++
422 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"