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,
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,
30 #include "HsVersions.h"
32 import Ratio ( Rational )
33 import IOExts ( unsafePerformIO )
34 import IO ( hPutStrLn, stderr )
36 import AbsCSyn ( node, tagreg, MagicId(..) )
37 import ForeignCall ( CCallConv )
38 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
39 import PrimRep ( PrimRep(..) )
40 import MachOp ( MachOp(..), pprMachOp )
41 import Unique ( Unique )
42 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
43 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
44 UniqSM, thenUs, returnUs, getUniqueUs )
45 import Maybes ( Maybe012(..), maybe012ToList )
50 Two types, StixStmt and StixValue, define Stix.
54 -- Non-value trees; ones executed for their side-effect.
57 = -- Directive for the assembler to change segment
60 -- Assembly-language comments
61 | StComment FAST_STRING
63 -- Assignments are typed to determine size and register placement.
64 -- Assign a value to a StixReg
65 | StAssignReg PrimRep StixReg StixExpr
67 -- Assign a value to memory. First tree indicates the address to be
68 -- assigned to, so there is an implicit dereference here.
69 | StAssignMem PrimRep StixExpr StixExpr -- dst, src
71 -- Do a machine op which generates multiple values, and assign
72 -- the results to the lvalues stated here.
73 | StAssignMachOp (Maybe012 StixVReg) MachOp [StixExpr]
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 -- used by insnFuture in RegAllocInfo.lhs
158 = NoDestInfo -- no supplied dests; infer from context
159 | DestInfo [CLabel] -- precisely these dests and no others
161 hasDestInfo NoDestInfo = False
162 hasDestInfo (DestInfo _) = True
164 pprDests :: DestInfo -> SDoc
165 pprDests NoDestInfo = text "NoDestInfo"
166 pprDests (DestInfo dsts) = brackets (hsep (map pprCLabel dsts))
169 pprStixStmts :: [StixStmt] -> SDoc
172 vcat (map pprStixStmt ts),
178 pprStixExpr :: StixExpr -> SDoc
181 StCLbl lbl -> pprCLabel lbl
182 StInt i -> (if i < 0 then parens else id) (integer i)
183 StFloat rat -> parens (text "Float" <+> rational rat)
184 StDouble rat -> parens (text "Double" <+> rational rat)
185 StString str -> parens (text "Str `" <> ptext str <> char '\'')
186 StIndex k b o -> parens (pprStixExpr b <+> char '+' <>
187 ppr k <+> pprStixExpr o)
188 StInd k t -> ppr k <> char '[' <> pprStixExpr t <> char ']'
189 StReg reg -> pprStixReg reg
190 StMachOp op args -> pprMachOp op
191 <> parens (hsep (punctuate comma (map pprStixExpr args)))
193 -> parens (text "Call" <+> ptext nm <+>
195 hsep (map pprStixExpr args))
197 pprStixStmt :: StixStmt -> SDoc
200 StSegment cseg -> parens (ppCodeSegment cseg)
201 StComment str -> parens (text "Comment" <+> ptext str)
202 StAssignReg pr reg rhs
203 -> pprStixReg reg <> text " :=" <> ppr pr
204 <> text " " <> pprStixExpr rhs
205 StAssignMem pr addr rhs
206 -> ppr pr <> char '[' <> pprStixExpr addr <> char ']'
207 <> text " :=" <> ppr pr
208 <> text " " <> pprStixExpr rhs
209 StAssignMachOp lhss mop args
210 -> parens (hcat (punctuate comma (
211 map pprStixVReg (maybe012ToList lhss)
215 <> parens (hsep (punctuate comma (map pprStixExpr args)))
216 StLabel ll -> pprCLabel ll <+> char ':'
217 StFunBegin ll -> char ' ' $$ parens (text "FunBegin" <+> pprCLabel ll)
218 StFunEnd ll -> parens (text "FunEnd" <+> pprCLabel ll)
219 StJump dsts t -> parens (text "Jump" <+> pprDests dsts <+> pprStixExpr t)
220 StFallThrough ll -> parens (text "FallThru" <+> pprCLabel ll)
221 StCondJump l t -> parens (text "JumpC" <+> pprCLabel l
223 StData k ds -> parens (text "Data" <+> ppr k <+>
224 hsep (map pprStixExpr ds))
225 StDataString str -> parens (text "DataString" <+> ppr str)
226 StVoidable expr -> text "(void)" <+> pprStixExpr expr
229 Stix registers can have two forms. They {\em may} or {\em may not}
230 map to real, machine-level registers.
234 = StixMagicId MagicId -- Regs which are part of the abstract machine model
236 | StixTemp StixVReg -- "Regs" which model local variables (CTemps) in
239 pprStixReg (StixMagicId mid) = ppMId mid
240 pprStixReg (StixTemp temp) = pprStixVReg temp
243 = StixVReg Unique PrimRep
245 pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, ppr pr, char ')']
249 ppMId BaseReg = text "BaseReg"
250 ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(",
251 int (iBox n), char ')']
252 ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')']
253 ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')']
254 ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(",
255 int (iBox n), char ')']
258 ppMId SpLim = text "SpLim"
260 ppMId HpLim = text "HpLim"
261 ppMId CurCostCentre = text "CCC"
262 ppMId VoidReg = text "VoidReg"
265 We hope that every machine supports the idea of data segment and text
266 segment (or that it has no segments at all, and we can lump these
276 ppCodeSegment = text . show
278 type StixStmtList = [StixStmt] -> [StixStmt]
281 Stix Trees for STG registers:
283 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
286 stgBaseReg = StixMagicId BaseReg
287 stgNode = StixMagicId node
288 stgTagReg = StixMagicId tagreg
289 stgSp = StixMagicId Sp
290 stgSu = StixMagicId Su
291 stgSpLim = StixMagicId SpLim
292 stgHp = StixMagicId Hp
293 stgHpLim = StixMagicId HpLim
294 stgHpAlloc = StixMagicId HpAlloc
295 stgCurrentTSO = StixMagicId CurrentTSO
296 stgCurrentNursery = StixMagicId CurrentNursery
297 stgR9 = StixMagicId (VanillaReg WordRep (_ILIT 9))
298 stgR10 = StixMagicId (VanillaReg WordRep (_ILIT 10))
300 getNatLabelNCG :: NatM CLabel
302 = getUniqueNat `thenNat` \ u ->
303 returnNat (mkAsmTempLabel u)
305 getUniqLabelNCG :: UniqSM CLabel
307 = getUniqueUs `thenUs` \ u ->
308 returnUs (mkAsmTempLabel u)
310 fixedHS = StInt (toInteger fixedHdrSize)
311 arrWordsHS = StInt (toInteger arrWordsHdrSize)
312 arrPtrsHS = StInt (toInteger arrPtrsHdrSize)
315 Stix optimisation passes may wish to find out how many times a
316 given temporary appears in a tree, so as to be able to decide
317 whether or not to inline the assignment's RHS at usage site(s).
320 stixExpr_CountTempUses :: Unique -> StixExpr -> Int
321 stixExpr_CountTempUses u t
322 = let qs = stixStmt_CountTempUses u
323 qe = stixExpr_CountTempUses u
324 qr = stixReg_CountTempUses u
328 StIndex pk t1 t2 -> qe t1 + qe t2
330 StMachOp mop ts -> sum (map qe ts)
331 StCall nm cconv pk ts -> sum (map qe ts)
338 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
339 stixStmt_CountTempUses u t
340 = let qe = stixExpr_CountTempUses u
341 qr = stixReg_CountTempUses u
342 qv = stixVReg_CountTempUses u
345 StAssignReg pk reg rhs -> qr reg + qe rhs
346 StAssignMem pk addr rhs -> qe addr + qe rhs
347 StJump dsts t1 -> qe t1
348 StCondJump lbl t1 -> qe t1
349 StData pk ts -> sum (map qe ts)
350 StAssignMachOp lhss mop args
351 -> sum (map qv (maybe012ToList lhss)) + sum (map qe args)
352 StVoidable expr -> qe expr
361 stixReg_CountTempUses u reg
363 StixTemp vreg -> stixVReg_CountTempUses u vreg
366 stixVReg_CountTempUses u (StixVReg uu pr)
367 = if u == uu then 1 else 0
370 If we do decide to inline a temporary binding, the following functions
374 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
375 stixStmt_Subst u new_u in_this_tree
376 = stixStmt_MapUniques f in_this_tree
378 f :: Unique -> Maybe StixExpr
379 f uu = if uu == u then Just new_u else Nothing
382 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
383 stixExpr_MapUniques f t
384 = let qe = stixExpr_MapUniques f
385 qs = stixStmt_MapUniques f
386 qr = stixReg_MapUniques f
389 StReg reg -> case qr reg of
392 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
393 StInd pk t1 -> StInd pk (qe t1)
394 StMachOp mop args -> StMachOp mop (map qe args)
395 StCall nm cconv pk ts -> StCall nm cconv pk (map qe ts)
402 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
403 stixStmt_MapUniques f t
404 = let qe = stixExpr_MapUniques f
405 qs = stixStmt_MapUniques f
406 qr = stixReg_MapUniques f
407 qv = stixVReg_MapUniques f
409 doMopLhss Just0 = Just0
413 other -> doMopLhss_panic
414 doMopLhss (Just2 r1 r2)
415 = case (qv r1, qv r2) of
416 (Nothing, Nothing) -> Just2 r1 r2
417 other -> doMopLhss_panic
418 -- Because the StixRegs processed by doMopLhss are lvalues, they
419 -- absolutely shouldn't be mapped to a StixExpr;
420 -- hence we panic if they do. Same deal for StAssignReg below.
422 = panic "stixStmt_MapUniques:doMopLhss"
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)
434 StAssignMachOp lhss mop args
435 -> StAssignMachOp (doMopLhss lhss) mop (map qe args)
445 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
446 stixReg_MapUniques f reg
448 StixMagicId mid -> Nothing
449 StixTemp vreg -> stixVReg_MapUniques f vreg
451 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
452 stixVReg_MapUniques f (StixVReg uu pr)
457 -- Lift StStrings out of top-level StDatas, putting them at the end of
458 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
459 {- Motivation for this hackery provided by the following bug:
463 (Data P_ Addr.A#_static_info)
464 (Data StgAddr (Str `alalal'))
469 .global Bogon_ping_closure
471 .long Addr_Azh_static_info
482 ie, the Str is planted in-line, when what we really meant was to place
483 a _reference_ to the string there. liftStrings will lift out all such
484 strings in top-level data and place them at the end of the block.
486 This is still a rather half-baked solution -- to do the job entirely right
487 would mean a complete traversal of all the Stixes, but there's currently no
488 real need for it, and it would be slow. Also, potentially there could be
489 literal types other than strings which need lifting out?
492 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
494 = liftStrings_wrk stmts [] []
496 liftStrings_wrk :: [StixStmt] -- originals
497 -> [StixStmt] -- (reverse) originals with strings lifted out
498 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
501 -- First, examine the original trees and lift out strings in top-level StDatas.
502 liftStrings_wrk (st:sts) acc_stix acc_strs
505 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
506 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
508 -> liftStrings_wrk sts (other:acc_stix) acc_strs
510 -- Handle a top-level StData
511 lift [] acc_strs = returnUs ([], acc_strs)
513 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
516 -> getUniqueUs `thenUs` \ unq ->
517 let lbl = mkAsmTempLabel unq in
518 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
520 -> returnUs (other:ds_done, acc_strs1)
522 -- When we've run out of original trees, emit the lifted strings.
523 liftStrings_wrk [] acc_stix acc_strs
524 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
526 f (lbl,str) = [StSegment RoDataSegment,
529 StSegment TextSegment]
535 data NatM_State = NatM_State UniqSupply Int
536 type NatM result = NatM_State -> (result, NatM_State)
538 mkNatM_State :: UniqSupply -> Int -> NatM_State
539 mkNatM_State = NatM_State
541 uniqOfNatM_State (NatM_State us delta) = us
542 deltaOfNatM_State (NatM_State us delta) = delta
545 initNat :: NatM_State -> NatM a -> (a, NatM_State)
546 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
548 thenNat :: NatM a -> (a -> NatM b) -> NatM b
550 = case expr st of { (result, st') -> cont result st' }
552 returnNat :: a -> NatM a
553 returnNat result st = (result, st)
555 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
556 mapNat f [] = returnNat []
558 = f x `thenNat` \ r ->
559 mapNat f xs `thenNat` \ rs ->
562 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
563 mapAndUnzipNat f [] = returnNat ([],[])
564 mapAndUnzipNat f (x:xs)
565 = f x `thenNat` \ (r1, r2) ->
566 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
567 returnNat (r1:rs1, r2:rs2)
569 mapAccumLNat :: (acc -> x -> NatM (acc, y))
576 mapAccumLNat f b (x:xs)
577 = f b x `thenNat` \ (b__2, x__2) ->
578 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
579 returnNat (b__3, x__2:xs__2)
582 getUniqueNat :: NatM Unique
583 getUniqueNat (NatM_State us delta)
584 = case splitUniqSupply us of
585 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
587 getDeltaNat :: NatM Int
588 getDeltaNat st@(NatM_State us delta)
591 setDeltaNat :: Int -> NatM ()
592 setDeltaNat delta (NatM_State us _)
593 = ((), NatM_State us delta)
596 Giving up in a not-too-inelegant way.
599 ncgPrimopMoan :: String -> SDoc -> a
600 ncgPrimopMoan msg pp_rep
604 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
605 "machinery. You can work around this for the time being by compiling\n" ++
606 "this module via the C route, by giving the flag -fvia-C.\n" ++
607 "The panic below contains information, intended for the GHC implementors,\n" ++
608 "about the exact place where GHC gave up. Please send it to us\n" ++
609 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"