2 % (c) The AQUA Project, Glasgow University, 1993-1998
7 CodeSegment(..), StixReg(..), StixExpr(..), StixVReg(..),
8 StixStmt(..), mkStAssign, StixStmtList,
9 pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg,
10 stixStmt_CountTempUses, stixStmt_Subst,
11 liftStrings, repOfStixExpr,
12 DestInfo(..), hasDestInfo,
14 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
15 stgHp, stgHpLim, stgHpAlloc, stgTagReg, stgR9, stgR10,
16 stgCurrentTSO, stgCurrentNursery,
18 fixedHS, arrWordsHS, arrPtrsHS,
20 NatM, initNat, thenNat, returnNat,
21 mapNat, mapAndUnzipNat, mapAccumLNat,
22 getUniqueNat, getDeltaNat, setDeltaNat,
23 NatM_State, mkNatM_State,
24 uniqOfNatM_State, deltaOfNatM_State,
26 getUniqLabelNCG, getNatLabelNCG,
29 -- Information about the target arch
33 #include "HsVersions.h"
35 import Ratio ( Rational )
36 import IOExts ( unsafePerformIO )
37 import IO ( hPutStrLn, stderr )
39 import AbsCSyn ( node, tagreg, MagicId(..) )
40 import AbsCUtils ( magicIdPrimRep )
41 import ForeignCall ( CCallConv )
42 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
43 import PrimRep ( PrimRep(..) )
44 import MachOp ( MachOp(..), pprMachOp, resultRepsOfMachOp )
45 import Unique ( Unique )
46 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
47 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
48 UniqSM, thenUs, returnUs, getUniqueUs )
49 import Constants ( wORD_SIZE )
54 Two types, StixStmt and StixValue, define Stix.
58 -- Non-value trees; ones executed for their side-effect.
61 = -- Directive for the assembler to change segment
64 -- Assembly-language comments
65 | StComment FAST_STRING
67 -- Assignments are typed to determine size and register placement.
68 -- Assign a value to a StixReg
69 | StAssignReg PrimRep StixReg StixExpr
71 -- Assign a value to memory. First tree indicates the address to be
72 -- assigned to, so there is an implicit dereference here.
73 | StAssignMem PrimRep StixExpr StixExpr -- dst, src
75 -- A simple assembly label that we might jump to.
78 -- A function header and footer
82 -- An unconditional jump. This instruction may or may not jump
83 -- out of the register allocation domain (basic block, more or
84 -- less). For correct register allocation when this insn is used
85 -- to jump through a jump table, we optionally allow a list of
86 -- the exact targets to be attached, so that the allocator can
87 -- easily construct the exact flow edges leaving this insn.
88 -- Dynamic targets are allowed.
89 | StJump DestInfo StixExpr
91 -- 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
96 | StCondJump CLabel StixExpr
98 -- Raw data (as in an info table).
99 | StData PrimRep [StixExpr]
100 -- String which has been lifted to the top level (sigh).
101 | StDataString FAST_STRING
103 -- A value computed only for its side effects; result is discarded
104 -- (A handy trapdoor to allow CCalls with no results to appear as
106 | StVoidable StixExpr
109 -- Helper fn to make Stix assignment statements where the
110 -- lvalue masquerades as a StixExpr. A kludge that should
111 -- be done away with.
112 mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
113 mkStAssign rep (StReg reg) rhs
114 = StAssignReg rep reg rhs
115 mkStAssign rep (StInd rep' addr) rhs
116 | rep `isCloseEnoughTo` rep'
117 = StAssignMem rep addr rhs
119 = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
120 --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
121 StAssignMem rep addr rhs
124 isCloseEnoughTo r1 r2
125 = r1 == r2 || (wordIsh r1 && wordIsh r2)
127 = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep,
128 RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep]
129 -- determined by looking at PrimRep.showPrimRep
131 -- Stix trees which denote a value.
134 StInt Integer -- ** add Kind at some point
137 | StString FAST_STRING
138 | StCLbl CLabel -- labels that we might index into
140 -- Abstract registers of various kinds
143 -- A typed offset from a base location
144 | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
146 -- An indirection from an address to its contents.
147 | StInd PrimRep StixExpr
149 -- Primitive Operations
150 | StMachOp MachOp [StixExpr]
152 -- Calls to C functions
153 | StCall FAST_STRING CCallConv PrimRep [StixExpr]
156 -- What's the PrimRep of the value denoted by this StixExpr?
157 repOfStixExpr :: StixExpr -> PrimRep
158 repOfStixExpr (StInt _) = IntRep
159 repOfStixExpr (StFloat _) = FloatRep
160 repOfStixExpr (StDouble _) = DoubleRep
161 repOfStixExpr (StString _) = PtrRep
162 repOfStixExpr (StCLbl _) = PtrRep
163 repOfStixExpr (StReg reg) = repOfStixReg reg
164 repOfStixExpr (StIndex _ _ _) = PtrRep
165 repOfStixExpr (StInd rep _) = rep
166 repOfStixExpr (StCall target conv retrep args) = retrep
167 repOfStixExpr (StMachOp mop args)
168 = case resultRepsOfMachOp mop of
170 Nothing -> pprPanic "repOfStixExpr:StMachOp" (pprMachOp mop)
173 -- used by insnFuture in RegAllocInfo.lhs
175 = NoDestInfo -- no supplied dests; infer from context
176 | DestInfo [CLabel] -- precisely these dests and no others
178 hasDestInfo NoDestInfo = False
179 hasDestInfo (DestInfo _) = True
181 pprDests :: DestInfo -> SDoc
182 pprDests NoDestInfo = text "NoDestInfo"
183 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
186 pprStixStmts :: [StixStmt] -> SDoc
189 vcat (map pprStixStmt ts),
195 pprStixExpr :: StixExpr -> SDoc
198 StCLbl lbl -> pprCLabel lbl
199 StInt i -> (if i < 0 then parens else id) (integer i)
200 StFloat rat -> parens (text "Float" <+> rational rat)
201 StDouble rat -> parens (text "Double" <+> rational rat)
202 StString str -> parens (text "Str `" <> ptext str <> char '\'')
203 StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
204 ppr k <+> pprStixExpr o)
205 StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
206 StReg reg -> pprStixReg reg
207 StMachOp op args -> pprMachOp op
208 <> parens (hsep (punctuate comma (map pprStixExpr args)))
210 -> parens (text "Call" <+> ptext nm <+>
212 hsep (map pprStixExpr args))
214 pprStixStmt :: StixStmt -> SDoc
217 StSegment cseg -> parens (ppCodeSegment cseg)
218 StComment str -> parens (text "Comment" <+> ptext str)
219 StAssignReg pr reg rhs
220 -> pprStixReg reg <> text " :=" <> ppr pr
221 <> text " " <> pprStixExpr rhs
222 StAssignMem pr addr rhs
223 -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
224 <> text " :=" <> ppr pr
225 <> text " " <> pprStixExpr rhs
226 StLabel ll -> pprCLabel ll <+> char ':'
227 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
228 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
229 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
230 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
231 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
233 StData k ds -> parens (text "Data" <+> ppr k <+>
234 hsep (map pprStixExpr ds))
235 StDataString str -> parens (text "DataString" <+> ppr str)
236 StVoidable expr -> text "(void)" <+> pprStixExpr expr
239 Stix registers can have two forms. They {\em may} or {\em may not}
240 map to real, machine-level registers.
244 = StixMagicId MagicId -- Regs which are part of the abstract machine model
246 | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
249 pprStixReg (StixMagicId mid) = ppMId mid
250 pprStixReg (StixTemp temp) = pprStixVReg temp
252 repOfStixReg (StixTemp (StixVReg u pr)) = pr
253 repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
256 = StixVReg Unique PrimRep
258 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
262 ppMId BaseReg = text "BaseReg"
263 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
264 int (iBox n), char ')']
265 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
266 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
267 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
268 int (iBox n), char ')']
271 ppMId SpLim = text "SpLim"
273 ppMId HpLim = text "HpLim"
274 ppMId CurCostCentre = text "CCC"
275 ppMId VoidReg = text "VoidReg"
278 We hope that every machine supports the idea of data segment and text
279 segment (or that it has no segments at all, and we can lump these
289 ppCodeSegment = text . show
291 type StixStmtList = [StixStmt] -> [StixStmt]
294 Stix Trees for STG registers:
296 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
299 stgBaseReg = StixMagicId BaseReg
300 stgNode = StixMagicId node
301 stgTagReg = StixMagicId tagreg
302 stgSp = StixMagicId Sp
303 stgSu = StixMagicId Su
304 stgSpLim = StixMagicId SpLim
305 stgHp = StixMagicId Hp
306 stgHpLim = StixMagicId HpLim
307 stgHpAlloc = StixMagicId HpAlloc
308 stgCurrentTSO = StixMagicId CurrentTSO
309 stgCurrentNursery = StixMagicId CurrentNursery
310 stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
311 stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
313 getNatLabelNCG :: NatM CLabel
315 = getUniqueNat `thenNat` \ u ->
316 returnNat (mkAsmTempLabel u)
318 getUniqLabelNCG :: UniqSM CLabel
320 = getUniqueUs `thenUs` \ u ->
321 returnUs (mkAsmTempLabel u)
323 fixedHS = StInt (toInteger fixedHdrSize)
324 arrWordsHS = StInt (toInteger arrWordsHdrSize)
325 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
328 Stix optimisation passes may wish to find out how many times a
329 given temporary appears in a tree, so as to be able to decide
330 whether or not to inline the assignment's RHS at usage site(s).
333 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
334 stixExpr_CountTempUses u t
335 = let qs = stixStmt_CountTempUses u
336 qe = stixExpr_CountTempUses u
337 qr = stixReg_CountTempUses u
341 StIndex pk t1 t2 -> qe t1 + qe t2
343 StMachOp mop ts -> sum (map qe ts)
344 StCall nm cconv pk ts -> sum (map qe ts)
351 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
352 stixStmt_CountTempUses u t
353 = let qe = stixExpr_CountTempUses u
354 qr = stixReg_CountTempUses u
355 qv = stixVReg_CountTempUses u
358 StAssignReg pk reg rhs -> qr reg + qe rhs
359 StAssignMem pk addr rhs -> qe addr + qe rhs
360 StJump dsts t1 -> qe t1
361 StCondJump lbl t1 -> qe t1
362 StData pk ts -> sum (map qe ts)
363 StVoidable expr -> qe expr
372 stixReg_CountTempUses u reg
374 StixTemp vreg -> stixVReg_CountTempUses u vreg
377 stixVReg_CountTempUses u (StixVReg uu pr)
378 = if u == uu then 1 else 0
381 If we do decide to inline a temporary binding, the following functions
385 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
386 stixStmt_Subst u new_u in_this_tree
387 = stixStmt_MapUniques f in_this_tree
389 f :: Unique -> Maybe StixExpr
390 f uu = if uu == u then Just new_u else Nothing
393 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
394 stixExpr_MapUniques f t
395 = let qe = stixExpr_MapUniques f
396 qs = stixStmt_MapUniques f
397 qr = stixReg_MapUniques f
400 StReg reg -> case qr reg of
403 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
404 StInd pk t1 -> StInd pk (qe t1)
405 StMachOp mop args -> StMachOp mop (map qe args)
406 StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts)
413 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
414 stixStmt_MapUniques f t
415 = let qe = stixExpr_MapUniques f
416 qs = stixStmt_MapUniques f
417 qr = stixReg_MapUniques f
418 qv = stixVReg_MapUniques f
421 StAssignReg pk reg rhs
423 Nothing -> StAssignReg pk reg (qe rhs)
424 Just xx -> panic "stixStmt_MapUniques:StAssignReg"
425 StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
426 StJump dsts t1 -> StJump dsts (qe t1)
427 StCondJump lbl t1 -> StCondJump lbl (qe t1)
428 StData pk ts -> StData pk (map qe ts)
429 StVoidable expr -> StVoidable (qe expr)
439 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
440 stixReg_MapUniques f reg
442 StixMagicId mid -> Nothing
443 StixTemp vreg -> stixVReg_MapUniques f vreg
445 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
446 stixVReg_MapUniques f (StixVReg uu pr)
451 -- Lift StStrings out of top-level StDatas, putting them at the end of
452 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
453 {- Motivation for this hackery provided by the following bug:
457 (Data P_ Addr.A#_static_info)
458 (Data StgAddr (Str `alalal'))
463 .global Bogon_ping_closure
465 .long Addr_Azh_static_info
476 ie, the Str is planted in-line, when what we really meant was to place
477 a _reference_ to the string there. liftStrings will lift out all such
478 strings in top-level data and place them at the end of the block.
480 This is still a rather half-baked solution -- to do the job entirely right
481 would mean a complete traversal of all the Stixes, but there's currently no
482 real need for it, and it would be slow. Also, potentially there could be
483 literal types other than strings which need lifting out?
486 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
488 = liftStrings_wrk stmts [] []
490 liftStrings_wrk :: [StixStmt] -- originals
491 -> [StixStmt] -- (reverse) originals with strings lifted out
492 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
495 -- First, examine the original trees and lift out strings in top-level StDatas.
496 liftStrings_wrk (st:sts) acc_stix acc_strs
499 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
500 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
502 -> liftStrings_wrk sts (other:acc_stix) acc_strs
504 -- Handle a top-level StData
505 lift [] acc_strs = returnUs ([], acc_strs)
507 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
510 -> getUniqueUs `thenUs` \ unq ->
511 let lbl = mkAsmTempLabel unq in
512 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
514 -> returnUs (other:ds_done, acc_strs1)
516 -- When we've run out of original trees, emit the lifted strings.
517 liftStrings_wrk [] acc_stix acc_strs
518 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
520 f (lbl,str) = [StSegment RoDataSegment,
523 StSegment TextSegment]
529 data NatM_State = NatM_State UniqSupply Int
530 type NatM result = NatM_State -> (result, NatM_State)
532 mkNatM_State :: UniqSupply -> Int -> NatM_State
533 mkNatM_State = NatM_State
535 uniqOfNatM_State (NatM_State us delta) = us
536 deltaOfNatM_State (NatM_State us delta) = delta
539 initNat :: NatM_State -> NatM a -> (a, NatM_State)
540 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
542 thenNat :: NatM a -> (a -> NatM b) -> NatM b
544 = case expr st of { (result, st') -> cont result st' }
546 returnNat :: a -> NatM a
547 returnNat result st = (result, st)
549 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
550 mapNat f [] = returnNat []
552 = f x `thenNat` \ r ->
553 mapNat f xs `thenNat` \ rs ->
556 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
557 mapAndUnzipNat f [] = returnNat ([],[])
558 mapAndUnzipNat f (x:xs)
559 = f x `thenNat` \ (r1, r2) ->
560 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
561 returnNat (r1:rs1, r2:rs2)
563 mapAccumLNat :: (acc -> x -> NatM (acc, y))
570 mapAccumLNat f b (x:xs)
571 = f b x `thenNat` \ (b__2, x__2) ->
572 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
573 returnNat (b__3, x__2:xs__2)
576 getUniqueNat :: NatM Unique
577 getUniqueNat (NatM_State us delta)
578 = case splitUniqSupply us of
579 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
581 getDeltaNat :: NatM Int
582 getDeltaNat st@(NatM_State us delta)
585 setDeltaNat :: Int -> NatM ()
586 setDeltaNat delta (NatM_State us _)
587 = ((), NatM_State us delta)
590 Giving up in a not-too-inelegant way.
593 ncgPrimopMoan :: String -> SDoc -> a
594 ncgPrimopMoan msg pp_rep
598 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
599 "machinery. You can work around this for the time being by compiling\n" ++
600 "this module via the C route, by giving the flag -fvia-C.\n" ++
601 "The panic below contains information, intended for the GHC implementors,\n" ++
602 "about the exact place where GHC gave up. Please send it to us\n" ++
603 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
610 Information about the target.
614 ncg_target_is_32bit :: Bool
615 ncg_target_is_32bit | wORD_SIZE == 4 = True
616 | wORD_SIZE == 8 = False