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, 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 AbsCSyn ( node, tagreg, MagicId(..) )
36 import AbsCUtils ( magicIdPrimRep )
37 import ForeignCall ( CCallConv )
38 import CLabel ( mkAsmTempLabel, CLabel, pprCLabel )
39 import PrimRep ( PrimRep(..) )
40 import MachOp ( MachOp(..), pprMachOp, resultRepOfMachOp )
41 import Unique ( Unique )
42 import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
43 import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply,
44 UniqSM, thenUs, returnUs, getUniqueUs )
45 import Constants ( wORD_SIZE )
50 import UNSAFE_IO ( unsafePerformIO )
52 import Ratio ( Rational )
53 import IO ( hPutStrLn, stderr )
56 Two types, StixStmt and StixValue, define Stix.
60 -- Non-value trees; ones executed for their side-effect.
63 = -- Directive for the assembler to change segment
66 -- Assembly-language comments
67 | StComment FastString
69 -- Assignments are typed to determine size and register placement.
70 -- Assign a value to a StixReg
71 | StAssignReg PrimRep StixReg StixExpr
73 -- Assign a value to memory. First tree indicates the address to be
74 -- assigned to, so there is an implicit dereference here.
75 | StAssignMem PrimRep StixExpr StixExpr -- dst, src
77 -- A simple assembly label that we might jump to.
80 -- A function header and footer
84 -- An unconditional jump. This instruction may or may not jump
85 -- out of the register allocation domain (basic block, more or
86 -- less). For correct register allocation when this insn is used
87 -- to jump through a jump table, we optionally allow a list of
88 -- the exact targets to be attached, so that the allocator can
89 -- easily construct the exact flow edges leaving this insn.
90 -- Dynamic targets are allowed.
91 | StJump DestInfo StixExpr
93 -- A fall-through, from slow to fast
94 | StFallThrough CLabel
96 -- A conditional jump. This instruction can be non-terminal :-)
97 -- Only static, local, forward labels are allowed
98 | StCondJump CLabel StixExpr
100 -- Raw data (as in an info table).
101 | StData PrimRep [StixExpr]
102 -- String which has been lifted to the top level (sigh).
103 | StDataString FastString
105 -- A value computed only for its side effects; result is discarded
106 -- (A handy trapdoor to allow CCalls with no results to appear as
108 | StVoidable StixExpr
111 -- Helper fn to make Stix assignment statements where the
112 -- lvalue masquerades as a StixExpr. A kludge that should
113 -- be done away with.
114 mkStAssign :: PrimRep -> StixExpr -> StixExpr -> StixStmt
115 mkStAssign rep (StReg reg) rhs
116 = StAssignReg rep reg rhs
117 mkStAssign rep (StInd rep' addr) rhs
118 | rep `isCloseEnoughTo` rep'
119 = StAssignMem rep addr rhs
121 = --pprPanic "Stix.mkStAssign: mismatched reps" (ppr rep <+> ppr rep')
122 --trace ("Stix.mkStAssign: mismatched reps: " ++ showSDoc (ppr rep <+> ppr rep')) (
123 StAssignMem rep addr rhs
126 isCloseEnoughTo r1 r2
127 = r1 == r2 || (wordIsh r1 && wordIsh r2)
129 = rep `elem` [IntRep, WordRep, PtrRep, AddrRep, CodePtrRep, RetRep ]
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 ')']
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, stgSpLim, stgHp, stgHpLim :: StixReg
300 stgBaseReg = StixMagicId BaseReg
301 stgNode = StixMagicId node
302 stgTagReg = StixMagicId tagreg
303 stgSp = StixMagicId Sp
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 (Left nm) cconv pk ts -> sum (map qe ts)
345 StCall (Right f) cconv pk ts -> sum (map qe ts) + qe f
352 stixStmt_CountTempUses :: Unique -> StixStmt -> Int
353 stixStmt_CountTempUses u t
354 = let qe = stixExpr_CountTempUses u
355 qr = stixReg_CountTempUses u
356 qv = stixVReg_CountTempUses u
359 StAssignReg pk reg rhs -> qr reg + qe rhs
360 StAssignMem pk addr rhs -> qe addr + qe rhs
361 StJump dsts t1 -> qe t1
362 StCondJump lbl t1 -> qe t1
363 StData pk ts -> sum (map qe ts)
364 StVoidable expr -> qe expr
373 stixReg_CountTempUses u reg
375 StixTemp vreg -> stixVReg_CountTempUses u vreg
378 stixVReg_CountTempUses u (StixVReg uu pr)
379 = if u == uu then 1 else 0
382 If we do decide to inline a temporary binding, the following functions
386 stixStmt_Subst :: Unique -> StixExpr -> StixStmt -> StixStmt
387 stixStmt_Subst u new_u in_this_tree
388 = stixStmt_MapUniques f in_this_tree
390 f :: Unique -> Maybe StixExpr
391 f uu = if uu == u then Just new_u else Nothing
394 stixExpr_MapUniques :: (Unique -> Maybe StixExpr) -> StixExpr -> StixExpr
395 stixExpr_MapUniques f t
396 = let qe = stixExpr_MapUniques f
397 qs = stixStmt_MapUniques f
398 qr = stixReg_MapUniques f
401 StReg reg -> case qr reg of
404 StIndex pk t1 t2 -> StIndex pk (qe t1) (qe t2)
405 StInd pk t1 -> StInd pk (qe t1)
406 StMachOp mop args -> StMachOp mop (map qe args)
407 StCall (Left nm) cconv pk ts -> StCall (Left nm) cconv pk (map qe ts)
408 StCall (Right f) cconv pk ts -> StCall (Right (qe f)) cconv pk (map qe ts)
415 stixStmt_MapUniques :: (Unique -> Maybe StixExpr) -> StixStmt -> StixStmt
416 stixStmt_MapUniques f t
417 = let qe = stixExpr_MapUniques f
418 qs = stixStmt_MapUniques f
419 qr = stixReg_MapUniques f
420 qv = stixVReg_MapUniques f
423 StAssignReg pk reg rhs
425 Nothing -> StAssignReg pk reg (qe rhs)
426 Just xx -> panic "stixStmt_MapUniques:StAssignReg"
427 StAssignMem pk addr rhs -> StAssignMem pk (qe addr) (qe rhs)
428 StJump dsts t1 -> StJump dsts (qe t1)
429 StCondJump lbl t1 -> StCondJump lbl (qe t1)
430 StData pk ts -> StData pk (map qe ts)
431 StVoidable expr -> StVoidable (qe expr)
441 stixReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixReg -> Maybe StixExpr
442 stixReg_MapUniques f reg
444 StixMagicId mid -> Nothing
445 StixTemp vreg -> stixVReg_MapUniques f vreg
447 stixVReg_MapUniques :: (Unique -> Maybe StixExpr) -> StixVReg -> Maybe StixExpr
448 stixVReg_MapUniques f (StixVReg uu pr)
453 -- Lift StStrings out of top-level StDatas, putting them at the end of
454 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
455 {- Motivation for this hackery provided by the following bug:
459 (Data P_ Addr.A#_static_info)
460 (Data StgAddr (Str `alalal'))
465 .global Bogon_ping_closure
467 .long Addr_Azh_static_info
478 ie, the Str is planted in-line, when what we really meant was to place
479 a _reference_ to the string there. liftStrings will lift out all such
480 strings in top-level data and place them at the end of the block.
482 This is still a rather half-baked solution -- to do the job entirely right
483 would mean a complete traversal of all the Stixes, but there's currently no
484 real need for it, and it would be slow. Also, potentially there could be
485 literal types other than strings which need lifting out?
488 liftStrings :: [StixStmt] -> UniqSM [StixStmt]
490 = liftStrings_wrk stmts [] []
492 liftStrings_wrk :: [StixStmt] -- originals
493 -> [StixStmt] -- (reverse) originals with strings lifted out
494 -> [(CLabel, FastString)] -- lifted strs, and their new labels
497 -- First, examine the original trees and lift out strings in top-level StDatas.
498 liftStrings_wrk (st:sts) acc_stix acc_strs
501 -> lift datas acc_strs `thenUs` \ (datas_done, acc_strs1) ->
502 liftStrings_wrk sts ((StData sz datas_done):acc_stix) acc_strs1
504 -> liftStrings_wrk sts (other:acc_stix) acc_strs
506 -- Handle a top-level StData
507 lift [] acc_strs = returnUs ([], acc_strs)
509 = lift ds acc_strs `thenUs` \ (ds_done, acc_strs1) ->
512 -> getUniqueUs `thenUs` \ unq ->
513 let lbl = mkAsmTempLabel unq in
514 returnUs ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
516 -> returnUs (other:ds_done, acc_strs1)
518 -- When we've run out of original trees, emit the lifted strings.
519 liftStrings_wrk [] acc_stix acc_strs
520 = returnUs (reverse acc_stix ++ concatMap f acc_strs)
522 f (lbl,str) = [StSegment RoDataSegment,
525 StSegment TextSegment]
531 data NatM_State = NatM_State UniqSupply Int
532 type NatM result = NatM_State -> (result, NatM_State)
534 mkNatM_State :: UniqSupply -> Int -> NatM_State
535 mkNatM_State = NatM_State
537 uniqOfNatM_State (NatM_State us delta) = us
538 deltaOfNatM_State (NatM_State us delta) = delta
541 initNat :: NatM_State -> NatM a -> (a, NatM_State)
542 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
544 thenNat :: NatM a -> (a -> NatM b) -> NatM b
546 = case expr st of { (result, st') -> cont result st' }
548 returnNat :: a -> NatM a
549 returnNat result st = (result, st)
551 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
552 mapNat f [] = returnNat []
554 = f x `thenNat` \ r ->
555 mapNat f xs `thenNat` \ rs ->
558 mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c])
559 mapAndUnzipNat f [] = returnNat ([],[])
560 mapAndUnzipNat f (x:xs)
561 = f x `thenNat` \ (r1, r2) ->
562 mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
563 returnNat (r1:rs1, r2:rs2)
565 mapAccumLNat :: (acc -> x -> NatM (acc, y))
572 mapAccumLNat f b (x:xs)
573 = f b x `thenNat` \ (b__2, x__2) ->
574 mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) ->
575 returnNat (b__3, x__2:xs__2)
578 getUniqueNat :: NatM Unique
579 getUniqueNat (NatM_State us delta)
580 = case splitUniqSupply us of
581 (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
583 getDeltaNat :: NatM Int
584 getDeltaNat st@(NatM_State us delta)
587 setDeltaNat :: Int -> NatM ()
588 setDeltaNat delta (NatM_State us _)
589 = ((), NatM_State us delta)
592 Giving up in a not-too-inelegant way.
595 ncgPrimopMoan :: String -> SDoc -> a
596 ncgPrimopMoan msg pp_rep
600 "You've fallen across an unimplemented case in GHC's native code generation\n" ++
601 "machinery. You can work around this for the time being by compiling\n" ++
602 "this module via the C route, by giving the flag -fvia-C.\n" ++
603 "The panic below contains information, intended for the GHC implementors,\n" ++
604 "about the exact place where GHC gave up. Please send it to us\n" ++
605 "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
612 Information about the target.
616 ncg_target_is_32bit :: Bool
617 ncg_target_is_32bit | wORD_SIZE == 4 = True
618 | wORD_SIZE == 8 = False