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, resultRepOfMachOp )
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 )
55 Two types, StixStmt and StixValue, define Stix.
59 -- Non-value trees; ones executed for their side-effect.
62 = -- Directive for the assembler to change segment
65 -- Assembly-language comments
66 | StComment FastString
68 -- Assignments are typed to determine size and register placement.
69 -- Assign a value to a StixReg
70 | StAssignReg PrimRep StixReg StixExpr
72 -- Assign a value to memory. First tree indicates the address to be
73 -- assigned to, so there is an implicit dereference here.
74 | StAssignMem PrimRep StixExpr StixExpr -- dst, src
76 -- A simple assembly label that we might jump to.
79 -- A function header and footer
83 -- An unconditional jump. This instruction may or may not jump
84 -- out of the register allocation domain (basic block, more or
85 -- less). For correct register allocation when this insn is used
86 -- to jump through a jump table, we optionally allow a list of
87 -- the exact targets to be attached, so that the allocator can
88 -- easily construct the exact flow edges leaving this insn.
89 -- Dynamic targets are allowed.
90 | StJump DestInfo StixExpr
92 -- A fall-through, from slow to fast
93 | StFallThrough CLabel
95 -- A conditional jump. This instruction can be non-terminal :-)
96 -- Only static, local, forward labels are allowed
97 | StCondJump CLabel StixExpr
99 -- Raw data (as in an info table).
100 | StData PrimRep [StixExpr]
101 -- String which has been lifted to the top level (sigh).
102 | StDataString FastString
104 -- A value computed only for its side effects; result is discarded
105 -- (A handy trapdoor to allow CCalls with no results to appear as
107 | StVoidable StixExpr
110 -- Helper fn to make Stix assignment statements where the
111 -- lvalue masquerades as a StixExpr. A kludge that should
112 -- be done away with.
113 mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
114 mkStAssign rep (StReg reg) rhs
115 = StAssignReg rep reg rhs
116 mkStAssign rep (StInd rep' addr) rhs
117 | rep `isCloseEnoughTo` rep'
118 = StAssignMem rep addr rhs
120 = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
121 --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
122 StAssignMem rep addr rhs
125 isCloseEnoughTo r1 r2
126 = r1 == r2 || (wordIsh r1 && wordIsh r2)
128 = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ]
129 -- determined by looking at PrimRep.showPrimRep
131 -- Stix trees which denote a value.
134 StInt Integer -- ** add Kind at some point
137 | StString FastString
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 (Either FastString StixExpr) -- Left: static, Right: dynamic
154 CCallConv PrimRep [StixExpr]
157 -- What's the PrimRep of the value denoted by this StixExpr?
158 repOfStixExpr :: StixExpr -> PrimRep
159 repOfStixExpr (StInt _) = IntRep
160 repOfStixExpr (StFloat _) = FloatRep
161 repOfStixExpr (StDouble _) = DoubleRep
162 repOfStixExpr (StString _) = PtrRep
163 repOfStixExpr (StCLbl _) = PtrRep
164 repOfStixExpr (StReg reg) = repOfStixReg reg
165 repOfStixExpr (StIndex _ _ _) = PtrRep
166 repOfStixExpr (StInd rep _) = rep
167 repOfStixExpr (StCall target conv retrep args) = retrep
168 repOfStixExpr (StMachOp mop args) = resultRepOfMachOp mop
171 -- used by insnFuture in RegAllocInfo.lhs
173 = NoDestInfo -- no supplied dests; infer from context
174 | DestInfo [CLabel] -- precisely these dests and no others
176 hasDestInfo NoDestInfo = False
177 hasDestInfo (DestInfo _) = True
179 pprDests :: DestInfo -> SDoc
180 pprDests NoDestInfo = text "NoDestInfo"
181 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
184 pprStixStmts :: [StixStmt] -> SDoc
187 vcat (map pprStixStmt ts),
193 pprStixExpr :: StixExpr -> SDoc
196 StCLbl lbl -> pprCLabel lbl
197 StInt i -> (if i < 0 then parens else id) (integer i)
198 StFloat rat -> parens (text "Float" <+> rational rat)
199 StDouble rat -> parens (text "Double" <+> rational rat)
200 StString str -> parens (text "Str `" <> ftext str <> char '\'')
201 StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
202 ppr k <+> pprStixExpr o)
203 StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
204 StReg reg -> pprStixReg reg
205 StMachOp op args -> pprMachOp op
206 <> parens (hsep (punctuate comma (map pprStixExpr args)))
208 -> parens (text "Call" <+> targ <+>
210 hsep (map pprStixExpr args))
213 Left t_static -> ftext t_static
214 Right t_dyn -> parens (pprStixExpr t_dyn)
216 pprStixStmt :: StixStmt -> SDoc
219 StSegment cseg -> parens (ppCodeSegment cseg)
220 StComment str -> parens (text "Comment" <+> ftext str)
221 StAssignReg pr reg rhs
222 -> pprStixReg reg <> text " :=" <> ppr pr
223 <> text " " <> pprStixExpr rhs
224 StAssignMem pr addr rhs
225 -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
226 <> text " :=" <> ppr pr
227 <> text " " <> pprStixExpr rhs
228 StLabel ll -> pprCLabel ll <+> char ':'
229 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
230 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
231 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
232 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
233 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
235 StData k ds -> parens (text "Data" <+> ppr k <+>
236 hsep (map pprStixExpr ds))
237 StDataString str -> parens (text "DataString" <+> ppr str)
238 StVoidable expr -> text "(void)" <+> pprStixExpr expr
241 Stix registers can have two forms. They {\em may} or {\em may not}
242 map to real, machine-level registers.
246 = StixMagicId MagicId -- Regs which are part of the abstract machine model
248 | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
251 pprStixReg (StixMagicId mid) = ppMId mid
252 pprStixReg (StixTemp temp) = pprStixVReg temp
254 repOfStixReg (StixTemp (StixVReg u pr)) = pr
255 repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
258 = StixVReg Unique PrimRep
260 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
264 ppMId BaseReg = text "BaseReg"
265 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
266 int (iBox n), char ')']
267 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
268 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
269 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
270 int (iBox n), char ')']
273 ppMId SpLim = text "SpLim"
275 ppMId HpLim = text "HpLim"
276 ppMId CurCostCentre = text "CCC"
277 ppMId VoidReg = text "VoidReg"
280 We hope that every machine supports the idea of data segment and text
281 segment (or that it has no segments at all, and we can lump these
291 ppCodeSegment = text . show
293 type StixStmtList = [StixStmt] -> [StixStmt]
296 Stix Trees for STG registers:
298 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
301 stgBaseReg = StixMagicId BaseReg
302 stgNode = StixMagicId node
303 stgTagReg = StixMagicId tagreg
304 stgSp = StixMagicId Sp
305 stgSu = StixMagicId Su
306 stgSpLim = StixMagicId SpLim
307 stgHp = StixMagicId Hp
308 stgHpLim = StixMagicId HpLim
309 stgHpAlloc = StixMagicId HpAlloc
310 stgCurrentTSO = StixMagicId CurrentTSO
311 stgCurrentNursery = StixMagicId CurrentNursery
312 stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
313 stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
315 getNatLabelNCG :: NatM CLabel
317 = getUniqueNat `thenNat` \ u ->
318 returnNat (mkAsmTempLabel u)
320 getUniqLabelNCG :: UniqSM CLabel
322 = getUniqueUs `thenUs` \ u ->
323 returnUs (mkAsmTempLabel u)
325 fixedHS = StInt (toInteger fixedHdrSize)
326 arrWordsHS = StInt (toInteger arrWordsHdrSize)
327 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
330 Stix optimisation passes may wish to find out how many times a
331 given temporary appears in a tree, so as to be able to decide
332 whether or not to inline the assignment's RHS at usage site(s).
335 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
336 stixExpr_CountTempUses u t
337 = let qs = stixStmt_CountTempUses u
338 qe = stixExpr_CountTempUses u
339 qr = stixReg_CountTempUses u
343 StIndex pk t1 t2 -> qe t1 + qe t2
345 StMachOp mop ts -> sum (map qe ts)
346 StCall (Left nm) cconv pk ts -> sum (map qe ts)
347 StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
354 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
355 stixStmt_CountTempUses u t
356 = let qe = stixExpr_CountTempUses u
357 qr = stixReg_CountTempUses u
358 qv = stixVReg_CountTempUses u
361 StAssignReg pk reg rhs -> qr reg + qe rhs
362 StAssignMem pk addr rhs -> qe addr + qe rhs
363 StJump dsts t1 -> qe t1
364 StCondJump lbl t1 -> qe t1
365 StData pk ts -> sum (map qe ts)
366 StVoidable expr -> qe expr
375 stixReg_CountTempUses u reg
377 StixTemp vreg -> stixVReg_CountTempUses u vreg
380 stixVReg_CountTempUses u (StixVReg uu pr)
381 = if u == uu then 1 else 0
384 If we do decide to inline a temporary binding, the following functions
388 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
389 stixStmt_Subst u new_u in_this_tree
390 = stixStmt_MapUniques f in_this_tree
392 f :: Unique -> Maybe StixExpr
393 f uu = if uu == u then Just new_u else Nothing
396 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
397 stixExpr_MapUniques f t
398 = let qe = stixExpr_MapUniques f
399 qs = stixStmt_MapUniques f
400 qr = stixReg_MapUniques f
403 StReg reg -> case qr reg of
406 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
407 StInd pk t1 -> StInd pk (qe t1)
408 StMachOp mop args -> StMachOp mop (map qe args)
409 StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
410 StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
417 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
418 stixStmt_MapUniques f t
419 = let qe = stixExpr_MapUniques f
420 qs = stixStmt_MapUniques f
421 qr = stixReg_MapUniques f
422 qv = stixVReg_MapUniques f
425 StAssignReg pk reg rhs
427 Nothing -> StAssignReg pk reg (qe rhs)
428 Just xx -> panic "stixStmt_MapUniques:StAssignReg"
429 StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
430 StJump dsts t1 -> StJump dsts (qe t1)
431 StCondJump lbl t1 -> StCondJump lbl (qe t1)
432 StData pk ts -> StData pk (map qe ts)
433 StVoidable expr -> StVoidable (qe expr)
443 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
444 stixReg_MapUniques f reg
446 StixMagicId mid -> Nothing
447 StixTemp vreg -> stixVReg_MapUniques f vreg
449 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
450 stixVReg_MapUniques f (StixVReg uu pr)
455 -- Lift StStrings out of top-level StDatas, putting them at the end of
456 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
457 {- Motivation for this hackery provided by the following bug:
461 (Data P_ Addr.A#_static_info)
462 (Data StgAddr (Str `alalal'))
467 .global Bogon_ping_closure
469 .long Addr_Azh_static_info
480 ie, the Str is planted in-line, when what we really meant was to place
481 a _reference_ to the string there. liftStrings will lift out all such
482 strings in top-level data and place them at the end of the block.
484 This is still a rather half-baked solution -- to do the job entirely right
485 would mean a complete traversal of all the Stixes, but there's currently no
486 real need for it, and it would be slow. Also, potentially there could be
487 literal types other than strings which need lifting out?
490 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
492 = liftStrings_wrk stmts [] []
494 liftStrings_wrk :: [StixStmt] -- originals
495 -> [StixStmt] -- (reverse) originals with strings lifted out
496 -> [(CLabel, FastString)] -- lifted strs, and their new labels
499 -- First, examine the original trees and lift out strings in top-level StDatas.
500 liftStrings_wrk (st:sts) acc_stix acc_strs
503 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
504 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
506 -> liftStrings_wrk sts (other:acc_stix) acc_strs
508 -- Handle a top-level StData
509 lift [] acc_strs = returnUs ([], acc_strs)
511 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
514 -> getUniqueUs `thenUs` \ unq ->
515 let lbl = mkAsmTempLabel unq in
516 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
518 -> returnUs (other:ds_done, acc_strs1)
520 -- When we've run out of original trees, emit the lifted strings.
521 liftStrings_wrk [] acc_stix acc_strs
522 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
524 f (lbl,str) = [StSegment RoDataSegment,
527 StSegment TextSegment]
533 data NatM_State = NatM_State UniqSupply Int
534 type NatM result = NatM_State -> (result, NatM_State)
536 mkNatM_State :: UniqSupply -> Int -> NatM_State
537 mkNatM_State = NatM_State
539 uniqOfNatM_State (NatM_State us delta) = us
540 deltaOfNatM_State (NatM_State us delta) = delta
543 initNat :: NatM_State -> NatM a -> (a, NatM_State)
544 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
546 thenNat :: NatM a -> (a -> NatM b) -> NatM b
548 = case expr st of { (result, st') -> cont result st' }
550 returnNat :: a -> NatM a
551 returnNat result st = (result, st)
553 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
554 mapNat f [] = returnNat []
556 = f x `thenNat` \ r ->
557 mapNat f xs `thenNat` \ rs ->
560 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
561 mapAndUnzipNat f [] = returnNat ([],[])
562 mapAndUnzipNat f (x:xs)
563 = f x `thenNat` \ (r1, r2) ->
564 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
565 returnNat (r1:rs1, r2:rs2)
567 mapAccumLNat :: (acc -> x -> NatM (acc, y))
574 mapAccumLNat f b (x:xs)
575 = f b x `thenNat` \ (b__2, x__2) ->
576 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
577 returnNat (b__3, x__2:xs__2)
580 getUniqueNat :: NatM Unique
581 getUniqueNat (NatM_State us delta)
582 = case splitUniqSupply us of
583 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
585 getDeltaNat :: NatM Int
586 getDeltaNat st@(NatM_State us delta)
589 setDeltaNat :: Int -> NatM ()
590 setDeltaNat delta (NatM_State us _)
591 = ((), NatM_State us delta)
594 Giving up in a not-too-inelegant way.
597 ncgPrimopMoan :: String -> SDoc -> a
598 ncgPrimopMoan msg pp_rep
602 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
603 "machinery. You can work around this for the time being by compiling\n" ++
604 "this module via the C route, by giving the flag -fvia-C.\n" ++
605 "The panic below contains information, intended for the GHC implementors,\n" ++
606 "about the exact place where GHC gave up. Please send it to us\n" ++
607 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
614 Information about the target.
618 ncg_target_is_32bit :: Bool
619 ncg_target_is_32bit | wORD_SIZE == 4 = True
620 | wORD_SIZE == 8 = False