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 (Either FAST_STRING 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)
169 = case resultRepsOfMachOp mop of
171 Nothing -> pprPanic "repOfStixExpr:StMachOp" (pprMachOp mop)
174 -- used by insnFuture in RegAllocInfo.lhs
176 = NoDestInfo -- no supplied dests; infer from context
177 | DestInfo [CLabel] -- precisely these dests and no others
179 hasDestInfo NoDestInfo = False
180 hasDestInfo (DestInfo _) = True
182 pprDests :: DestInfo -> SDoc
183 pprDests NoDestInfo = text "NoDestInfo"
184 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
187 pprStixStmts :: [StixStmt] -> SDoc
190 vcat (map pprStixStmt ts),
196 pprStixExpr :: StixExpr -> SDoc
199 StCLbl lbl -> pprCLabel lbl
200 StInt i -> (if i < 0 then parens else id) (integer i)
201 StFloat rat -> parens (text "Float" <+> rational rat)
202 StDouble rat -> parens (text "Double" <+> rational rat)
203 StString str -> parens (text "Str `" <> ptext str <> char '\'')
204 StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
205 ppr k <+> pprStixExpr o)
206 StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
207 StReg reg -> pprStixReg reg
208 StMachOp op args -> pprMachOp op
209 <> parens (hsep (punctuate comma (map pprStixExpr args)))
211 -> parens (text "Call" <+> targ <+>
213 hsep (map pprStixExpr args))
216 Left t_static -> ptext t_static
217 Right t_dyn -> parens (pprStixExpr t_dyn)
219 pprStixStmt :: StixStmt -> SDoc
222 StSegment cseg -> parens (ppCodeSegment cseg)
223 StComment str -> parens (text "Comment" <+> ptext str)
224 StAssignReg pr reg rhs
225 -> pprStixReg reg <> text " :=" <> ppr pr
226 <> text " " <> pprStixExpr rhs
227 StAssignMem pr addr rhs
228 -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
229 <> text " :=" <> ppr pr
230 <> text " " <> pprStixExpr rhs
231 StLabel ll -> pprCLabel ll <+> char ':'
232 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
233 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
234 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
235 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
236 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
238 StData k ds -> parens (text "Data" <+> ppr k <+>
239 hsep (map pprStixExpr ds))
240 StDataString str -> parens (text "DataString" <+> ppr str)
241 StVoidable expr -> text "(void)" <+> pprStixExpr expr
244 Stix registers can have two forms. They {\em may} or {\em may not}
245 map to real, machine-level registers.
249 = StixMagicId MagicId -- Regs which are part of the abstract machine model
251 | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
254 pprStixReg (StixMagicId mid) = ppMId mid
255 pprStixReg (StixTemp temp) = pprStixVReg temp
257 repOfStixReg (StixTemp (StixVReg u pr)) = pr
258 repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
261 = StixVReg Unique PrimRep
263 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
267 ppMId BaseReg = text "BaseReg"
268 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
269 int (iBox n), char ')']
270 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
271 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
272 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
273 int (iBox n), char ')']
276 ppMId SpLim = text "SpLim"
278 ppMId HpLim = text "HpLim"
279 ppMId CurCostCentre = text "CCC"
280 ppMId VoidReg = text "VoidReg"
283 We hope that every machine supports the idea of data segment and text
284 segment (or that it has no segments at all, and we can lump these
294 ppCodeSegment = text . show
296 type StixStmtList = [StixStmt] -> [StixStmt]
299 Stix Trees for STG registers:
301 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
304 stgBaseReg = StixMagicId BaseReg
305 stgNode = StixMagicId node
306 stgTagReg = StixMagicId tagreg
307 stgSp = StixMagicId Sp
308 stgSu = StixMagicId Su
309 stgSpLim = StixMagicId SpLim
310 stgHp = StixMagicId Hp
311 stgHpLim = StixMagicId HpLim
312 stgHpAlloc = StixMagicId HpAlloc
313 stgCurrentTSO = StixMagicId CurrentTSO
314 stgCurrentNursery = StixMagicId CurrentNursery
315 stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
316 stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
318 getNatLabelNCG :: NatM CLabel
320 = getUniqueNat `thenNat` \ u ->
321 returnNat (mkAsmTempLabel u)
323 getUniqLabelNCG :: UniqSM CLabel
325 = getUniqueUs `thenUs` \ u ->
326 returnUs (mkAsmTempLabel u)
328 fixedHS = StInt (toInteger fixedHdrSize)
329 arrWordsHS = StInt (toInteger arrWordsHdrSize)
330 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
333 Stix optimisation passes may wish to find out how many times a
334 given temporary appears in a tree, so as to be able to decide
335 whether or not to inline the assignment's RHS at usage site(s).
338 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
339 stixExpr_CountTempUses u t
340 = let qs = stixStmt_CountTempUses u
341 qe = stixExpr_CountTempUses u
342 qr = stixReg_CountTempUses u
346 StIndex pk t1 t2 -> qe t1 + qe t2
348 StMachOp mop ts -> sum (map qe ts)
349 StCall (Left nm) cconv pk ts -> sum (map qe ts)
350 StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
357 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
358 stixStmt_CountTempUses u t
359 = let qe = stixExpr_CountTempUses u
360 qr = stixReg_CountTempUses u
361 qv = stixVReg_CountTempUses u
364 StAssignReg pk reg rhs -> qr reg + qe rhs
365 StAssignMem pk addr rhs -> qe addr + qe rhs
366 StJump dsts t1 -> qe t1
367 StCondJump lbl t1 -> qe t1
368 StData pk ts -> sum (map qe ts)
369 StVoidable expr -> qe expr
378 stixReg_CountTempUses u reg
380 StixTemp vreg -> stixVReg_CountTempUses u vreg
383 stixVReg_CountTempUses u (StixVReg uu pr)
384 = if u == uu then 1 else 0
387 If we do decide to inline a temporary binding, the following functions
391 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
392 stixStmt_Subst u new_u in_this_tree
393 = stixStmt_MapUniques f in_this_tree
395 f :: Unique -> Maybe StixExpr
396 f uu = if uu == u then Just new_u else Nothing
399 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
400 stixExpr_MapUniques f t
401 = let qe = stixExpr_MapUniques f
402 qs = stixStmt_MapUniques f
403 qr = stixReg_MapUniques f
406 StReg reg -> case qr reg of
409 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
410 StInd pk t1 -> StInd pk (qe t1)
411 StMachOp mop args -> StMachOp mop (map qe args)
412 StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
413 StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
420 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
421 stixStmt_MapUniques f t
422 = let qe = stixExpr_MapUniques f
423 qs = stixStmt_MapUniques f
424 qr = stixReg_MapUniques f
425 qv = stixVReg_MapUniques f
428 StAssignReg pk reg rhs
430 Nothing -> StAssignReg pk reg (qe rhs)
431 Just xx -> panic "stixStmt_MapUniques:StAssignReg"
432 StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
433 StJump dsts t1 -> StJump dsts (qe t1)
434 StCondJump lbl t1 -> StCondJump lbl (qe t1)
435 StData pk ts -> StData pk (map qe ts)
436 StVoidable expr -> StVoidable (qe expr)
446 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
447 stixReg_MapUniques f reg
449 StixMagicId mid -> Nothing
450 StixTemp vreg -> stixVReg_MapUniques f vreg
452 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
453 stixVReg_MapUniques f (StixVReg uu pr)
458 -- Lift StStrings out of top-level StDatas, putting them at the end of
459 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
460 {- Motivation for this hackery provided by the following bug:
464 (Data P_ Addr.A#_static_info)
465 (Data StgAddr (Str `alalal'))
470 .global Bogon_ping_closure
472 .long Addr_Azh_static_info
483 ie, the Str is planted in-line, when what we really meant was to place
484 a _reference_ to the string there. liftStrings will lift out all such
485 strings in top-level data and place them at the end of the block.
487 This is still a rather half-baked solution -- to do the job entirely right
488 would mean a complete traversal of all the Stixes, but there's currently no
489 real need for it, and it would be slow. Also, potentially there could be
490 literal types other than strings which need lifting out?
493 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
495 = liftStrings_wrk stmts [] []
497 liftStrings_wrk :: [StixStmt] -- originals
498 -> [StixStmt] -- (reverse) originals with strings lifted out
499 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
502 -- First, examine the original trees and lift out strings in top-level StDatas.
503 liftStrings_wrk (st:sts) acc_stix acc_strs
506 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
507 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
509 -> liftStrings_wrk sts (other:acc_stix) acc_strs
511 -- Handle a top-level StData
512 lift [] acc_strs = returnUs ([], acc_strs)
514 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
517 -> getUniqueUs `thenUs` \ unq ->
518 let lbl = mkAsmTempLabel unq in
519 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
521 -> returnUs (other:ds_done, acc_strs1)
523 -- When we've run out of original trees, emit the lifted strings.
524 liftStrings_wrk [] acc_stix acc_strs
525 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
527 f (lbl,str) = [StSegment RoDataSegment,
530 StSegment TextSegment]
536 data NatM_State = NatM_State UniqSupply Int
537 type NatM result = NatM_State -> (result, NatM_State)
539 mkNatM_State :: UniqSupply -> Int -> NatM_State
540 mkNatM_State = NatM_State
542 uniqOfNatM_State (NatM_State us delta) = us
543 deltaOfNatM_State (NatM_State us delta) = delta
546 initNat :: NatM_State -> NatM a -> (a, NatM_State)
547 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
549 thenNat :: NatM a -> (a -> NatM b) -> NatM b
551 = case expr st of { (result, st') -> cont result st' }
553 returnNat :: a -> NatM a
554 returnNat result st = (result, st)
556 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
557 mapNat f [] = returnNat []
559 = f x `thenNat` \ r ->
560 mapNat f xs `thenNat` \ rs ->
563 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
564 mapAndUnzipNat f [] = returnNat ([],[])
565 mapAndUnzipNat f (x:xs)
566 = f x `thenNat` \ (r1, r2) ->
567 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
568 returnNat (r1:rs1, r2:rs2)
570 mapAccumLNat :: (acc -> x -> NatM (acc, y))
577 mapAccumLNat f b (x:xs)
578 = f b x `thenNat` \ (b__2, x__2) ->
579 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
580 returnNat (b__3, x__2:xs__2)
583 getUniqueNat :: NatM Unique
584 getUniqueNat (NatM_State us delta)
585 = case splitUniqSupply us of
586 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
588 getDeltaNat :: NatM Int
589 getDeltaNat st@(NatM_State us delta)
592 setDeltaNat :: Int -> NatM ()
593 setDeltaNat delta (NatM_State us _)
594 = ((), NatM_State us delta)
597 Giving up in a not-too-inelegant way.
600 ncgPrimopMoan :: String -> SDoc -> a
601 ncgPrimopMoan msg pp_rep
605 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
606 "machinery. You can work around this for the time being by compiling\n" ++
607 "this module via the C route, by giving the flag -fvia-C.\n" ++
608 "The panic below contains information, intended for the GHC implementors,\n" ++
609 "about the exact place where GHC gave up. Please send it to us\n" ++
610 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
617 Information about the target.
621 ncg_target_is_32bit :: Bool
622 ncg_target_is_32bit | wORD_SIZE == 4 = True
623 | wORD_SIZE == 8 = False