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,
129 RetRep, ArrayRep, PrimPtrRep, StableNameRep, BCORep]
130 -- determined by looking at PrimRep.showPrimRep
132 -- Stix trees which denote a value.
135 StInt Integer -- ** add Kind at some point
138 | StString FastString
139 | StCLbl CLabel -- labels that we might index into
141 -- Abstract registers of various kinds
144 -- A typed offset from a base location
145 | StIndex PrimRep StixExpr StixExpr -- kind, base, offset
147 -- An indirection from an address to its contents.
148 | StInd PrimRep StixExpr
150 -- Primitive Operations
151 | StMachOp MachOp [StixExpr]
153 -- Calls to C functions
154 | StCall (Either FastString StixExpr) -- Left: static, Right: dynamic
155 CCallConv PrimRep [StixExpr]
158 -- What's the PrimRep of the value denoted by this StixExpr?
159 repOfStixExpr :: StixExpr -> PrimRep
160 repOfStixExpr (StInt _) = IntRep
161 repOfStixExpr (StFloat _) = FloatRep
162 repOfStixExpr (StDouble _) = DoubleRep
163 repOfStixExpr (StString _) = PtrRep
164 repOfStixExpr (StCLbl _) = PtrRep
165 repOfStixExpr (StReg reg) = repOfStixReg reg
166 repOfStixExpr (StIndex _ _ _) = PtrRep
167 repOfStixExpr (StInd rep _) = rep
168 repOfStixExpr (StCall target conv retrep args) = retrep
169 repOfStixExpr (StMachOp mop args) = resultRepOfMachOp mop
172 -- used by insnFuture in RegAllocInfo.lhs
174 = NoDestInfo -- no supplied dests; infer from context
175 | DestInfo [CLabel] -- precisely these dests and no others
177 hasDestInfo NoDestInfo = False
178 hasDestInfo (DestInfo _) = True
180 pprDests :: DestInfo -> SDoc
181 pprDests NoDestInfo = text "NoDestInfo"
182 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
185 pprStixStmts :: [StixStmt] -> SDoc
188 vcat (map pprStixStmt ts),
194 pprStixExpr :: StixExpr -> SDoc
197 StCLbl lbl -> pprCLabel lbl
198 StInt i -> (if i < 0 then parens else id) (integer i)
199 StFloat rat -> parens (text "Float" <+> rational rat)
200 StDouble rat -> parens (text "Double" <+> rational rat)
201 StString str -> parens (text "Str `" <> ftext str <> char '\'')
202 StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
203 ppr k <+> pprStixExpr o)
204 StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
205 StReg reg -> pprStixReg reg
206 StMachOp op args -> pprMachOp op
207 <> parens (hsep (punctuate comma (map pprStixExpr args)))
209 -> parens (text "Call" <+> targ <+>
211 hsep (map pprStixExpr args))
214 Left t_static -> ftext t_static
215 Right t_dyn -> parens (pprStixExpr t_dyn)
217 pprStixStmt :: StixStmt -> SDoc
220 StSegment cseg -> parens (ppCodeSegment cseg)
221 StComment str -> parens (text "Comment" <+> ftext str)
222 StAssignReg pr reg rhs
223 -> pprStixReg reg <> text " :=" <> ppr pr
224 <> text " " <> pprStixExpr rhs
225 StAssignMem pr addr rhs
226 -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
227 <> text " :=" <> ppr pr
228 <> text " " <> pprStixExpr rhs
229 StLabel ll -> pprCLabel ll <+> char ':'
230 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
231 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
232 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
233 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
234 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
236 StData k ds -> parens (text "Data" <+> ppr k <+>
237 hsep (map pprStixExpr ds))
238 StDataString str -> parens (text "DataString" <+> ppr str)
239 StVoidable expr -> text "(void)" <+> pprStixExpr expr
242 Stix registers can have two forms. They {\em may} or {\em may not}
243 map to real, machine-level registers.
247 = StixMagicId MagicId -- Regs which are part of the abstract machine model
249 | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
252 pprStixReg (StixMagicId mid) = ppMId mid
253 pprStixReg (StixTemp temp) = pprStixVReg temp
255 repOfStixReg (StixTemp (StixVReg u pr)) = pr
256 repOfStixReg (StixMagicId mid) = magicIdPrimRep mid
259 = StixVReg Unique PrimRep
261 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')']
265 ppMId BaseReg = text "BaseReg"
266 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
267 int (iBox n), char ')']
268 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
269 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
270 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
271 int (iBox n), char ')']
274 ppMId SpLim = text "SpLim"
276 ppMId HpLim = text "HpLim"
277 ppMId CurCostCentre = text "CCC"
278 ppMId VoidReg = text "VoidReg"
281 We hope that every machine supports the idea of data segment and text
282 segment (or that it has no segments at all, and we can lump these
292 ppCodeSegment = text . show
294 type StixStmtList = [StixStmt] -> [StixStmt]
297 Stix Trees for STG registers:
299 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
302 stgBaseReg = StixMagicId BaseReg
303 stgNode = StixMagicId node
304 stgTagReg = StixMagicId tagreg
305 stgSp = StixMagicId Sp
306 stgSu = StixMagicId Su
307 stgSpLim = StixMagicId SpLim
308 stgHp = StixMagicId Hp
309 stgHpLim = StixMagicId HpLim
310 stgHpAlloc = StixMagicId HpAlloc
311 stgCurrentTSO = StixMagicId CurrentTSO
312 stgCurrentNursery = StixMagicId CurrentNursery
313 stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
314 stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
316 getNatLabelNCG :: NatM CLabel
318 = getUniqueNat `thenNat` \ u ->
319 returnNat (mkAsmTempLabel u)
321 getUniqLabelNCG :: UniqSM CLabel
323 = getUniqueUs `thenUs` \ u ->
324 returnUs (mkAsmTempLabel u)
326 fixedHS = StInt (toInteger fixedHdrSize)
327 arrWordsHS = StInt (toInteger arrWordsHdrSize)
328 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
331 Stix optimisation passes may wish to find out how many times a
332 given temporary appears in a tree, so as to be able to decide
333 whether or not to inline the assignment's RHS at usage site(s).
336 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
337 stixExpr_CountTempUses u t
338 = let qs = stixStmt_CountTempUses u
339 qe = stixExpr_CountTempUses u
340 qr = stixReg_CountTempUses u
344 StIndex pk t1 t2 -> qe t1 + qe t2
346 StMachOp mop ts -> sum (map qe ts)
347 StCall (Left nm) cconv pk ts -> sum (map qe ts)
348 StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
355 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
356 stixStmt_CountTempUses u t
357 = let qe = stixExpr_CountTempUses u
358 qr = stixReg_CountTempUses u
359 qv = stixVReg_CountTempUses u
362 StAssignReg pk reg rhs -> qr reg + qe rhs
363 StAssignMem pk addr rhs -> qe addr + qe rhs
364 StJump dsts t1 -> qe t1
365 StCondJump lbl t1 -> qe t1
366 StData pk ts -> sum (map qe ts)
367 StVoidable expr -> qe expr
376 stixReg_CountTempUses u reg
378 StixTemp vreg -> stixVReg_CountTempUses u vreg
381 stixVReg_CountTempUses u (StixVReg uu pr)
382 = if u == uu then 1 else 0
385 If we do decide to inline a temporary binding, the following functions
389 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
390 stixStmt_Subst u new_u in_this_tree
391 = stixStmt_MapUniques f in_this_tree
393 f :: Unique -> Maybe StixExpr
394 f uu = if uu == u then Just new_u else Nothing
397 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
398 stixExpr_MapUniques f t
399 = let qe = stixExpr_MapUniques f
400 qs = stixStmt_MapUniques f
401 qr = stixReg_MapUniques f
404 StReg reg -> case qr reg of
407 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
408 StInd pk t1 -> StInd pk (qe t1)
409 StMachOp mop args -> StMachOp mop (map qe args)
410 StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
411 StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
418 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
419 stixStmt_MapUniques f t
420 = let qe = stixExpr_MapUniques f
421 qs = stixStmt_MapUniques f
422 qr = stixReg_MapUniques f
423 qv = stixVReg_MapUniques f
426 StAssignReg pk reg rhs
428 Nothing -> StAssignReg pk reg (qe rhs)
429 Just xx -> panic "stixStmt_MapUniques:StAssignReg"
430 StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
431 StJump dsts t1 -> StJump dsts (qe t1)
432 StCondJump lbl t1 -> StCondJump lbl (qe t1)
433 StData pk ts -> StData pk (map qe ts)
434 StVoidable expr -> StVoidable (qe expr)
444 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
445 stixReg_MapUniques f reg
447 StixMagicId mid -> Nothing
448 StixTemp vreg -> stixVReg_MapUniques f vreg
450 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
451 stixVReg_MapUniques f (StixVReg uu pr)
456 -- Lift StStrings out of top-level StDatas, putting them at the end of
457 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
458 {- Motivation for this hackery provided by the following bug:
462 (Data P_ Addr.A#_static_info)
463 (Data StgAddr (Str `alalal'))
468 .global Bogon_ping_closure
470 .long Addr_Azh_static_info
481 ie, the Str is planted in-line, when what we really meant was to place
482 a _reference_ to the string there. liftStrings will lift out all such
483 strings in top-level data and place them at the end of the block.
485 This is still a rather half-baked solution -- to do the job entirely right
486 would mean a complete traversal of all the Stixes, but there's currently no
487 real need for it, and it would be slow. Also, potentially there could be
488 literal types other than strings which need lifting out?
491 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
493 = liftStrings_wrk stmts [] []
495 liftStrings_wrk :: [StixStmt] -- originals
496 -> [StixStmt] -- (reverse) originals with strings lifted out
497 -> [(CLabel, FastString)] -- lifted strs, and their new labels
500 -- First, examine the original trees and lift out strings in top-level StDatas.
501 liftStrings_wrk (st:sts) acc_stix acc_strs
504 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
505 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
507 -> liftStrings_wrk sts (other:acc_stix) acc_strs
509 -- Handle a top-level StData
510 lift [] acc_strs = returnUs ([], acc_strs)
512 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
515 -> getUniqueUs `thenUs` \ unq ->
516 let lbl = mkAsmTempLabel unq in
517 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
519 -> returnUs (other:ds_done, acc_strs1)
521 -- When we've run out of original trees, emit the lifted strings.
522 liftStrings_wrk [] acc_stix acc_strs
523 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
525 f (lbl,str) = [StSegment RoDataSegment,
528 StSegment TextSegment]
534 data NatM_State = NatM_State UniqSupply Int
535 type NatM result = NatM_State -> (result, NatM_State)
537 mkNatM_State :: UniqSupply -> Int -> NatM_State
538 mkNatM_State = NatM_State
540 uniqOfNatM_State (NatM_State us delta) = us
541 deltaOfNatM_State (NatM_State us delta) = delta
544 initNat :: NatM_State -> NatM a -> (a, NatM_State)
545 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
547 thenNat :: NatM a -> (a -> NatM b) -> NatM b
549 = case expr st of { (result, st') -> cont result st' }
551 returnNat :: a -> NatM a
552 returnNat result st = (result, st)
554 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
555 mapNat f [] = returnNat []
557 = f x `thenNat` \ r ->
558 mapNat f xs `thenNat` \ rs ->
561 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
562 mapAndUnzipNat f [] = returnNat ([],[])
563 mapAndUnzipNat f (x:xs)
564 = f x `thenNat` \ (r1, r2) ->
565 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
566 returnNat (r1:rs1, r2:rs2)
568 mapAccumLNat :: (acc -> x -> NatM (acc, y))
575 mapAccumLNat f b (x:xs)
576 = f b x `thenNat` \ (b__2, x__2) ->
577 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
578 returnNat (b__3, x__2:xs__2)
581 getUniqueNat :: NatM Unique
582 getUniqueNat (NatM_State us delta)
583 = case splitUniqSupply us of
584 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
586 getDeltaNat :: NatM Int
587 getDeltaNat st@(NatM_State us delta)
590 setDeltaNat :: Int -> NatM ()
591 setDeltaNat delta (NatM_State us _)
592 = ((), NatM_State us delta)
595 Giving up in a not-too-inelegant way.
598 ncgPrimopMoan :: String -> SDoc -> a
599 ncgPrimopMoan msg pp_rep
603 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
604 "machinery. You can work around this for the time being by compiling\n" ++
605 "this module via the C route, by giving the flag -fvia-C.\n" ++
606 "The panic below contains information, intended for the GHC implementors,\n" ++
607 "about the exact place where GHC gave up. Please send it to us\n" ++
608 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
615 Information about the target.
619 ncg_target_is_32bit :: Bool
620 ncg_target_is_32bit | wORD_SIZE == 4 = True
621 | wORD_SIZE == 8 = False