2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import AbsCUtils ( magicIdPrimRep )
22 import ForeignCall ( CCallConv(..) )
23 import CLabel ( CLabel, labelDynamic )
24 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
25 import CLabel ( isAsmTemp )
27 import Maybes ( maybeToBool )
28 import PrimRep ( isFloatingRep, PrimRep(..) )
29 import PrimOp ( PrimOp(..) )
30 import Stix ( getNatLabelNCG, StixTree(..),
31 StixReg(..), CodeSegment(..),
32 DestInfo, hasDestInfo,
34 NatM, thenNat, returnNat, mapNat,
35 mapAndUnzipNat, mapAccumLNat,
36 getDeltaNat, setDeltaNat,
40 import Outputable ( panic, pprPanic )
41 import qualified Outputable
42 import CmdLineOpts ( opt_Static )
47 @InstrBlock@s are the insn sequences generated by the insn selectors.
48 They are really trees of insns to facilitate fast appending, where a
49 left-to-right traversal (pre-order?) yields the insns in the correct
53 type InstrBlock = OrdList Instr
58 Code extractor for an entire stix tree---stix statement level.
61 stmtsToInstrs :: [StixTree] -> NatM InstrBlock
63 = liftStrings stmts [] [] `thenNat` \ lifted ->
64 mapNat stmtToInstrs lifted `thenNat` \ instrss ->
65 returnNat (concatOL instrss)
68 -- Lift StStrings out of top-level StDatas, putting them at the end of
69 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
70 {- Motivation for this hackery provided by the following bug:
74 (Data P_ Addr.A#_static_info)
75 (Data StgAddr (Str `alalal'))
80 .global Bogon_ping_closure
82 .long Addr_Azh_static_info
93 ie, the Str is planted in-line, when what we really meant was to place
94 a _reference_ to the string there. liftStrings will lift out all such
95 strings in top-level data and place them at the end of the block.
97 This is still a rather half-baked solution -- to do the job entirely right
98 would mean a complete traversal of all the Stixes, but there's currently no
99 real need for it, and it would be slow. Also, potentially there could be
100 literal types other than strings which need lifting out?
103 liftStrings :: [StixTree] -- originals
104 -> [StixTree] -- (reverse) originals with strings lifted out
105 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
108 -- First, examine the original trees and lift out strings in top-level StDatas.
109 liftStrings (st:sts) acc_stix acc_strs
112 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
113 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
115 -> liftStrings sts (other:acc_stix) acc_strs
117 -- Handle a top-level StData
118 lift [] acc_strs = returnNat ([], acc_strs)
120 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
123 -> getNatLabelNCG `thenNat` \ lbl ->
124 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
126 -> returnNat (other:ds_done, acc_strs1)
128 -- When we've run out of original trees, emit the lifted strings.
129 liftStrings [] acc_stix acc_strs
130 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
132 f (lbl,str) = [StSegment RoDataSegment,
135 StSegment TextSegment]
138 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
139 stmtToInstrs stmt = case stmt of
140 StComment s -> returnNat (unitOL (COMMENT s))
141 StSegment seg -> returnNat (unitOL (SEGMENT seg))
143 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
145 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
148 StLabel lab -> returnNat (unitOL (LABEL lab))
150 StJump dsts arg -> genJump dsts (derefDLL arg)
151 StCondJump lab arg -> genCondJump lab (derefDLL arg)
153 -- A call returning void, ie one done for its side-effects
154 StCall fn cconv VoidRep args -> genCCall fn
155 cconv VoidRep (map derefDLL args)
158 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
159 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
162 -- When falling through on the Alpha, we still have to load pv
163 -- with the address of the next routine, so that it can load gp.
164 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
168 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
169 returnNat (DATA (primRepToSize kind) imms
170 `consOL` concatOL codes)
172 getData :: StixTree -> NatM (InstrBlock, Imm)
173 getData (StInt i) = returnNat (nilOL, ImmInteger i)
174 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
175 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
176 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
177 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
178 -- the linker can handle simple arithmetic...
179 getData (StIndex rep (StCLbl lbl) (StInt off)) =
181 ImmIndex lbl (fromInteger off * sizeOf rep))
183 -- Top-level lifted-out string. The segment will already have been set
184 -- (see liftStrings above).
186 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
189 other -> pprPanic "stmtToInstrs" (pprStixTree other)
192 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
193 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
194 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
196 derefDLL :: StixTree -> StixTree
198 | opt_Static -- short out the entire deal if not doing DLLs
205 StCLbl lbl -> if labelDynamic lbl
206 then StInd PtrRep (StCLbl lbl)
208 -- all the rest are boring
209 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
210 StPrim pk args -> StPrim pk (map qq args)
211 StInd pk addr -> StInd pk (qq addr)
212 StCall who cc pk args -> StCall who cc pk (map qq args)
219 _ -> pprPanic "derefDLL: unhandled case"
223 %************************************************************************
225 \subsection{General things for putting together code sequences}
227 %************************************************************************
230 mangleIndexTree :: StixTree -> StixTree
232 mangleIndexTree (StIndex pk base (StInt i))
233 = StPrim IntAddOp [base, off]
235 off = StInt (i * toInteger (sizeOf pk))
237 mangleIndexTree (StIndex pk base off)
241 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
244 shift :: PrimRep -> Int
245 shift rep = case sizeOf rep of
250 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
251 (Outputable.int other)
255 maybeImm :: StixTree -> Maybe Imm
259 maybeImm (StIndex rep (StCLbl l) (StInt off))
260 = Just (ImmIndex l (fromInteger off * sizeOf rep))
262 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
263 = Just (ImmInt (fromInteger i))
265 = Just (ImmInteger i)
270 %************************************************************************
272 \subsection{The @Register@ type}
274 %************************************************************************
276 @Register@s passed up the tree. If the stix code forces the register
277 to live in a pre-decided machine register, it comes out as @Fixed@;
278 otherwise, it comes out as @Any@, and the parent can decide which
279 register to put it in.
283 = Fixed PrimRep Reg InstrBlock
284 | Any PrimRep (Reg -> InstrBlock)
286 registerCode :: Register -> Reg -> InstrBlock
287 registerCode (Fixed _ _ code) reg = code
288 registerCode (Any _ code) reg = code reg
290 registerCodeF (Fixed _ _ code) = code
291 registerCodeF (Any _ _) = panic "registerCodeF"
293 registerCodeA (Any _ code) = code
294 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
296 registerName :: Register -> Reg -> Reg
297 registerName (Fixed _ reg _) _ = reg
298 registerName (Any _ _) reg = reg
300 registerNameF (Fixed _ reg _) = reg
301 registerNameF (Any _ _) = panic "registerNameF"
303 registerRep :: Register -> PrimRep
304 registerRep (Fixed pk _ _) = pk
305 registerRep (Any pk _) = pk
307 {-# INLINE registerCode #-}
308 {-# INLINE registerCodeF #-}
309 {-# INLINE registerName #-}
310 {-# INLINE registerNameF #-}
311 {-# INLINE registerRep #-}
312 {-# INLINE isFixed #-}
315 isFixed, isAny :: Register -> Bool
316 isFixed (Fixed _ _ _) = True
317 isFixed (Any _ _) = False
319 isAny = not . isFixed
322 Generate code to get a subtree into a @Register@:
324 getRegister :: StixTree -> NatM Register
326 getRegister (StReg (StixMagicId stgreg))
327 = case (magicIdRegMaybe stgreg) of
328 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
331 getRegister (StReg (StixTemp u pk))
332 = returnNat (Fixed pk (mkVReg u pk) nilOL)
334 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
336 getRegister (StCall fn cconv kind args)
337 = genCCall fn cconv kind args `thenNat` \ call ->
338 returnNat (Fixed kind reg call)
340 reg = if isFloatingRep kind
341 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
342 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
344 getRegister (StString s)
345 = getNatLabelNCG `thenNat` \ lbl ->
347 imm_lbl = ImmCLbl lbl
350 SEGMENT RoDataSegment,
352 ASCII True (_UNPK_ s),
354 #if alpha_TARGET_ARCH
355 LDA dst (AddrImm imm_lbl)
358 MOV L (OpImm imm_lbl) (OpReg dst)
360 #if sparc_TARGET_ARCH
361 SETHI (HI imm_lbl) dst,
362 OR False dst (RIImm (LO imm_lbl)) dst
366 returnNat (Any PtrRep code)
370 -- end of machine-"independent" bit; here we go on the rest...
372 #if alpha_TARGET_ARCH
374 getRegister (StDouble d)
375 = getNatLabelNCG `thenNat` \ lbl ->
376 getNewRegNCG PtrRep `thenNat` \ tmp ->
377 let code dst = mkSeqInstrs [
380 DATA TF [ImmLab (rational d)],
382 LDA tmp (AddrImm (ImmCLbl lbl)),
383 LD TF dst (AddrReg tmp)]
385 returnNat (Any DoubleRep code)
387 getRegister (StPrim primop [x]) -- unary PrimOps
389 IntNegOp -> trivialUCode (NEG Q False) x
391 NotOp -> trivialUCode NOT x
393 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
394 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
396 OrdOp -> coerceIntCode IntRep x
399 Float2IntOp -> coerceFP2Int x
400 Int2FloatOp -> coerceInt2FP pr x
401 Double2IntOp -> coerceFP2Int x
402 Int2DoubleOp -> coerceInt2FP pr x
404 Double2FloatOp -> coerceFltCode x
405 Float2DoubleOp -> coerceFltCode x
407 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
409 fn = case other_op of
410 FloatExpOp -> SLIT("exp")
411 FloatLogOp -> SLIT("log")
412 FloatSqrtOp -> SLIT("sqrt")
413 FloatSinOp -> SLIT("sin")
414 FloatCosOp -> SLIT("cos")
415 FloatTanOp -> SLIT("tan")
416 FloatAsinOp -> SLIT("asin")
417 FloatAcosOp -> SLIT("acos")
418 FloatAtanOp -> SLIT("atan")
419 FloatSinhOp -> SLIT("sinh")
420 FloatCoshOp -> SLIT("cosh")
421 FloatTanhOp -> SLIT("tanh")
422 DoubleExpOp -> SLIT("exp")
423 DoubleLogOp -> SLIT("log")
424 DoubleSqrtOp -> SLIT("sqrt")
425 DoubleSinOp -> SLIT("sin")
426 DoubleCosOp -> SLIT("cos")
427 DoubleTanOp -> SLIT("tan")
428 DoubleAsinOp -> SLIT("asin")
429 DoubleAcosOp -> SLIT("acos")
430 DoubleAtanOp -> SLIT("atan")
431 DoubleSinhOp -> SLIT("sinh")
432 DoubleCoshOp -> SLIT("cosh")
433 DoubleTanhOp -> SLIT("tanh")
435 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
437 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
439 CharGtOp -> trivialCode (CMP LTT) y x
440 CharGeOp -> trivialCode (CMP LE) y x
441 CharEqOp -> trivialCode (CMP EQQ) x y
442 CharNeOp -> int_NE_code x y
443 CharLtOp -> trivialCode (CMP LTT) x y
444 CharLeOp -> trivialCode (CMP LE) x y
446 IntGtOp -> trivialCode (CMP LTT) y x
447 IntGeOp -> trivialCode (CMP LE) y x
448 IntEqOp -> trivialCode (CMP EQQ) x y
449 IntNeOp -> int_NE_code x y
450 IntLtOp -> trivialCode (CMP LTT) x y
451 IntLeOp -> trivialCode (CMP LE) x y
453 WordGtOp -> trivialCode (CMP ULT) y x
454 WordGeOp -> trivialCode (CMP ULE) x y
455 WordEqOp -> trivialCode (CMP EQQ) x y
456 WordNeOp -> int_NE_code x y
457 WordLtOp -> trivialCode (CMP ULT) x y
458 WordLeOp -> trivialCode (CMP ULE) x y
460 AddrGtOp -> trivialCode (CMP ULT) y x
461 AddrGeOp -> trivialCode (CMP ULE) y x
462 AddrEqOp -> trivialCode (CMP EQQ) x y
463 AddrNeOp -> int_NE_code x y
464 AddrLtOp -> trivialCode (CMP ULT) x y
465 AddrLeOp -> trivialCode (CMP ULE) x y
467 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
468 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
469 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
470 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
471 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
472 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
474 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
475 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
476 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
477 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
478 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
479 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
481 IntAddOp -> trivialCode (ADD Q False) x y
482 IntSubOp -> trivialCode (SUB Q False) x y
483 IntMulOp -> trivialCode (MUL Q False) x y
484 IntQuotOp -> trivialCode (DIV Q False) x y
485 IntRemOp -> trivialCode (REM Q False) x y
487 WordAddOp -> trivialCode (ADD Q False) x y
488 WordSubOp -> trivialCode (SUB Q False) x y
489 WordMulOp -> trivialCode (MUL Q False) x y
490 WordQuotOp -> trivialCode (DIV Q True) x y
491 WordRemOp -> trivialCode (REM Q True) x y
493 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
494 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
495 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
496 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
498 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
499 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
500 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
501 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
503 AddrAddOp -> trivialCode (ADD Q False) x y
504 AddrSubOp -> trivialCode (SUB Q False) x y
505 AddrRemOp -> trivialCode (REM Q True) x y
507 AndOp -> trivialCode AND x y
508 OrOp -> trivialCode OR x y
509 XorOp -> trivialCode XOR x y
510 SllOp -> trivialCode SLL x y
511 SrlOp -> trivialCode SRL x y
513 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
514 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
515 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
517 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
518 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
520 {- ------------------------------------------------------------
521 Some bizarre special code for getting condition codes into
522 registers. Integer non-equality is a test for equality
523 followed by an XOR with 1. (Integer comparisons always set
524 the result register to 0 or 1.) Floating point comparisons of
525 any kind leave the result in a floating point register, so we
526 need to wrangle an integer register out of things.
528 int_NE_code :: StixTree -> StixTree -> NatM Register
531 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
532 getNewRegNCG IntRep `thenNat` \ tmp ->
534 code = registerCode register tmp
535 src = registerName register tmp
536 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
538 returnNat (Any IntRep code__2)
540 {- ------------------------------------------------------------
541 Comments for int_NE_code also apply to cmpF_code
544 :: (Reg -> Reg -> Reg -> Instr)
546 -> StixTree -> StixTree
549 cmpF_code instr cond x y
550 = trivialFCode pr instr x y `thenNat` \ register ->
551 getNewRegNCG DoubleRep `thenNat` \ tmp ->
552 getNatLabelNCG `thenNat` \ lbl ->
554 code = registerCode register tmp
555 result = registerName register tmp
557 code__2 dst = code . mkSeqInstrs [
558 OR zeroh (RIImm (ImmInt 1)) dst,
559 BF cond result (ImmCLbl lbl),
560 OR zeroh (RIReg zeroh) dst,
563 returnNat (Any IntRep code__2)
565 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
566 ------------------------------------------------------------
568 getRegister (StInd pk mem)
569 = getAmode mem `thenNat` \ amode ->
571 code = amodeCode amode
572 src = amodeAddr amode
573 size = primRepToSize pk
574 code__2 dst = code . mkSeqInstr (LD size dst src)
576 returnNat (Any pk code__2)
578 getRegister (StInt i)
581 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
583 returnNat (Any IntRep code)
586 code dst = mkSeqInstr (LDI Q dst src)
588 returnNat (Any IntRep code)
590 src = ImmInt (fromInteger i)
595 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
597 returnNat (Any PtrRep code)
600 imm__2 = case imm of Just x -> x
602 #endif {- alpha_TARGET_ARCH -}
603 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
606 getRegister (StFloat f)
607 = getNatLabelNCG `thenNat` \ lbl ->
608 let code dst = toOL [
613 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
616 returnNat (Any FloatRep code)
619 getRegister (StDouble d)
622 = let code dst = unitOL (GLDZ dst)
623 in returnNat (Any DoubleRep code)
626 = let code dst = unitOL (GLD1 dst)
627 in returnNat (Any DoubleRep code)
630 = getNatLabelNCG `thenNat` \ lbl ->
631 let code dst = toOL [
634 DATA DF [ImmDouble d],
636 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
639 returnNat (Any DoubleRep code)
641 -- Calculate the offset for (i+1) words above the _initial_
642 -- %esp value by first determining the current offset of it.
643 getRegister (StScratchWord i)
645 = getDeltaNat `thenNat` \ current_stack_offset ->
646 let j = i+1 - (current_stack_offset `div` 4)
648 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
650 returnNat (Any PtrRep code)
652 getRegister (StPrim primop [x]) -- unary PrimOps
654 IntNegOp -> trivialUCode (NEGI L) x
655 NotOp -> trivialUCode (NOT L) x
657 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
658 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
660 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
661 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
663 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
664 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
666 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
667 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
669 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
670 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
672 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
673 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
675 OrdOp -> coerceIntCode IntRep x
678 Float2IntOp -> coerceFP2Int x
679 Int2FloatOp -> coerceInt2FP FloatRep x
680 Double2IntOp -> coerceFP2Int x
681 Int2DoubleOp -> coerceInt2FP DoubleRep x
684 getRegister (StCall fn CCallConv DoubleRep [x])
688 FloatExpOp -> (True, SLIT("exp"))
689 FloatLogOp -> (True, SLIT("log"))
691 FloatAsinOp -> (True, SLIT("asin"))
692 FloatAcosOp -> (True, SLIT("acos"))
693 FloatAtanOp -> (True, SLIT("atan"))
695 FloatSinhOp -> (True, SLIT("sinh"))
696 FloatCoshOp -> (True, SLIT("cosh"))
697 FloatTanhOp -> (True, SLIT("tanh"))
699 DoubleExpOp -> (False, SLIT("exp"))
700 DoubleLogOp -> (False, SLIT("log"))
702 DoubleAsinOp -> (False, SLIT("asin"))
703 DoubleAcosOp -> (False, SLIT("acos"))
704 DoubleAtanOp -> (False, SLIT("atan"))
706 DoubleSinhOp -> (False, SLIT("sinh"))
707 DoubleCoshOp -> (False, SLIT("cosh"))
708 DoubleTanhOp -> (False, SLIT("tanh"))
711 -> ncgPrimopMoan "getRegister(x86,unary primop)"
712 (pprStixTree (StPrim primop [x]))
714 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
716 CharGtOp -> condIntReg GTT x y
717 CharGeOp -> condIntReg GE x y
718 CharEqOp -> condIntReg EQQ x y
719 CharNeOp -> condIntReg NE x y
720 CharLtOp -> condIntReg LTT x y
721 CharLeOp -> condIntReg LE x y
723 IntGtOp -> condIntReg GTT x y
724 IntGeOp -> condIntReg GE x y
725 IntEqOp -> condIntReg EQQ x y
726 IntNeOp -> condIntReg NE x y
727 IntLtOp -> condIntReg LTT x y
728 IntLeOp -> condIntReg LE x y
730 WordGtOp -> condIntReg GU x y
731 WordGeOp -> condIntReg GEU x y
732 WordEqOp -> condIntReg EQQ x y
733 WordNeOp -> condIntReg NE x y
734 WordLtOp -> condIntReg LU x y
735 WordLeOp -> condIntReg LEU x y
737 AddrGtOp -> condIntReg GU x y
738 AddrGeOp -> condIntReg GEU x y
739 AddrEqOp -> condIntReg EQQ x y
740 AddrNeOp -> condIntReg NE x y
741 AddrLtOp -> condIntReg LU x y
742 AddrLeOp -> condIntReg LEU x y
744 FloatGtOp -> condFltReg GTT x y
745 FloatGeOp -> condFltReg GE x y
746 FloatEqOp -> condFltReg EQQ x y
747 FloatNeOp -> condFltReg NE x y
748 FloatLtOp -> condFltReg LTT x y
749 FloatLeOp -> condFltReg LE x y
751 DoubleGtOp -> condFltReg GTT x y
752 DoubleGeOp -> condFltReg GE x y
753 DoubleEqOp -> condFltReg EQQ x y
754 DoubleNeOp -> condFltReg NE x y
755 DoubleLtOp -> condFltReg LTT x y
756 DoubleLeOp -> condFltReg LE x y
758 IntAddOp -> add_code L x y
759 IntSubOp -> sub_code L x y
760 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
761 IntRemOp -> trivialCode (IREM L) Nothing x y
762 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
764 WordAddOp -> add_code L x y
765 WordSubOp -> sub_code L x y
766 WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
768 FloatAddOp -> trivialFCode FloatRep GADD x y
769 FloatSubOp -> trivialFCode FloatRep GSUB x y
770 FloatMulOp -> trivialFCode FloatRep GMUL x y
771 FloatDivOp -> trivialFCode FloatRep GDIV x y
773 DoubleAddOp -> trivialFCode DoubleRep GADD x y
774 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
775 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
776 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
778 AddrAddOp -> add_code L x y
779 AddrSubOp -> sub_code L x y
780 AddrRemOp -> trivialCode (IREM L) Nothing x y
782 AndOp -> let op = AND L in trivialCode op (Just op) x y
783 OrOp -> let op = OR L in trivialCode op (Just op) x y
784 XorOp -> let op = XOR L in trivialCode op (Just op) x y
786 {- Shift ops on x86s have constraints on their source, it
787 either has to be Imm, CL or 1
788 => trivialCode's is not restrictive enough (sigh.)
791 SllOp -> shift_code (SHL L) x y {-False-}
792 SrlOp -> shift_code (SHR L) x y {-False-}
793 ISllOp -> shift_code (SHL L) x y {-False-}
794 ISraOp -> shift_code (SAR L) x y {-False-}
795 ISrlOp -> shift_code (SHR L) x y {-False-}
797 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
798 [promote x, promote y])
799 where promote x = StPrim Float2DoubleOp [x]
800 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
803 -> ncgPrimopMoan "getRegister(x86,dyadic primop)"
804 (pprStixTree (StPrim primop [x, y]))
808 shift_code :: (Imm -> Operand -> Instr)
813 {- Case1: shift length as immediate -}
814 -- Code is the same as the first eq. for trivialCode -- sigh.
815 shift_code instr x y{-amount-}
817 = getRegister x `thenNat` \ regx ->
820 then registerCodeA regx dst `bind` \ code_x ->
822 instr imm__2 (OpReg dst)
823 else registerCodeF regx `bind` \ code_x ->
824 registerNameF regx `bind` \ r_x ->
826 MOV L (OpReg r_x) (OpReg dst) `snocOL`
827 instr imm__2 (OpReg dst)
829 returnNat (Any IntRep mkcode)
832 imm__2 = case imm of Just x -> x
834 {- Case2: shift length is complex (non-immediate) -}
835 -- Since ECX is always used as a spill temporary, we can't
836 -- use it here to do non-immediate shifts. No big deal --
837 -- they are only very rare, and we can use an equivalent
838 -- test-and-jump sequence which doesn't use ECX.
839 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
840 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
841 shift_code instr x y{-amount-}
842 = getRegister x `thenNat` \ register1 ->
843 getRegister y `thenNat` \ register2 ->
844 getNatLabelNCG `thenNat` \ lbl_test3 ->
845 getNatLabelNCG `thenNat` \ lbl_test2 ->
846 getNatLabelNCG `thenNat` \ lbl_test1 ->
847 getNatLabelNCG `thenNat` \ lbl_test0 ->
848 getNatLabelNCG `thenNat` \ lbl_after ->
849 getNewRegNCG IntRep `thenNat` \ tmp ->
851 = let src_val = registerName register1 dst
852 code_val = registerCode register1 dst
853 src_amt = registerName register2 tmp
854 code_amt = registerCode register2 tmp
859 MOV L (OpReg src_amt) r_tmp `appOL`
861 MOV L (OpReg src_val) r_dst `appOL`
863 COMMENT (_PK_ "begin shift sequence"),
864 MOV L (OpReg src_val) r_dst,
865 MOV L (OpReg src_amt) r_tmp,
867 BT L (ImmInt 4) r_tmp,
869 instr (ImmInt 16) r_dst,
872 BT L (ImmInt 3) r_tmp,
874 instr (ImmInt 8) r_dst,
877 BT L (ImmInt 2) r_tmp,
879 instr (ImmInt 4) r_dst,
882 BT L (ImmInt 1) r_tmp,
884 instr (ImmInt 2) r_dst,
887 BT L (ImmInt 0) r_tmp,
889 instr (ImmInt 1) r_dst,
892 COMMENT (_PK_ "end shift sequence")
895 returnNat (Any IntRep code__2)
898 add_code :: Size -> StixTree -> StixTree -> NatM Register
900 add_code sz x (StInt y)
901 = getRegister x `thenNat` \ register ->
902 getNewRegNCG IntRep `thenNat` \ tmp ->
904 code = registerCode register tmp
905 src1 = registerName register tmp
906 src2 = ImmInt (fromInteger y)
909 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
912 returnNat (Any IntRep code__2)
914 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
917 sub_code :: Size -> StixTree -> StixTree -> NatM Register
919 sub_code sz x (StInt y)
920 = getRegister x `thenNat` \ register ->
921 getNewRegNCG IntRep `thenNat` \ tmp ->
923 code = registerCode register tmp
924 src1 = registerName register tmp
925 src2 = ImmInt (-(fromInteger y))
928 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
931 returnNat (Any IntRep code__2)
933 sub_code sz x y = trivialCode (SUB sz) Nothing x y
936 getRegister (StInd pk mem)
937 = getAmode mem `thenNat` \ amode ->
939 code = amodeCode amode
940 src = amodeAddr amode
941 size = primRepToSize pk
942 code__2 dst = code `snocOL`
943 if pk == DoubleRep || pk == FloatRep
944 then GLD size src dst
952 (OpAddr src) (OpReg dst)
954 returnNat (Any pk code__2)
956 getRegister (StInt i)
958 src = ImmInt (fromInteger i)
961 = unitOL (XOR L (OpReg dst) (OpReg dst))
963 = unitOL (MOV L (OpImm src) (OpReg dst))
965 returnNat (Any IntRep code)
969 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
971 returnNat (Any PtrRep code)
973 = ncgPrimopMoan "getRegister(x86)" (pprStixTree leaf)
976 imm__2 = case imm of Just x -> x
978 #endif {- i386_TARGET_ARCH -}
979 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
980 #if sparc_TARGET_ARCH
982 getRegister (StFloat d)
983 = getNatLabelNCG `thenNat` \ lbl ->
984 getNewRegNCG PtrRep `thenNat` \ tmp ->
985 let code dst = toOL [
990 SETHI (HI (ImmCLbl lbl)) tmp,
991 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
993 returnNat (Any FloatRep code)
995 getRegister (StDouble d)
996 = getNatLabelNCG `thenNat` \ lbl ->
997 getNewRegNCG PtrRep `thenNat` \ tmp ->
998 let code dst = toOL [
1001 DATA DF [ImmDouble d],
1002 SEGMENT TextSegment,
1003 SETHI (HI (ImmCLbl lbl)) tmp,
1004 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1006 returnNat (Any DoubleRep code)
1008 -- The 6-word scratch area is immediately below the frame pointer.
1009 -- Below that is the spill area.
1010 getRegister (StScratchWord i)
1013 code dst = unitOL (fpRelEA (i-6) dst)
1015 returnNat (Any PtrRep code)
1018 getRegister (StPrim primop [x]) -- unary PrimOps
1020 IntNegOp -> trivialUCode (SUB False False g0) x
1021 NotOp -> trivialUCode (XNOR False g0) x
1023 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
1024 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
1026 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
1027 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
1029 OrdOp -> coerceIntCode IntRep x
1032 Float2IntOp -> coerceFP2Int x
1033 Int2FloatOp -> coerceInt2FP FloatRep x
1034 Double2IntOp -> coerceFP2Int x
1035 Int2DoubleOp -> coerceInt2FP DoubleRep x
1039 fixed_x = if is_float_op -- promote to double
1040 then StPrim Float2DoubleOp [x]
1043 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1047 FloatExpOp -> (True, SLIT("exp"))
1048 FloatLogOp -> (True, SLIT("log"))
1049 FloatSqrtOp -> (True, SLIT("sqrt"))
1051 FloatSinOp -> (True, SLIT("sin"))
1052 FloatCosOp -> (True, SLIT("cos"))
1053 FloatTanOp -> (True, SLIT("tan"))
1055 FloatAsinOp -> (True, SLIT("asin"))
1056 FloatAcosOp -> (True, SLIT("acos"))
1057 FloatAtanOp -> (True, SLIT("atan"))
1059 FloatSinhOp -> (True, SLIT("sinh"))
1060 FloatCoshOp -> (True, SLIT("cosh"))
1061 FloatTanhOp -> (True, SLIT("tanh"))
1063 DoubleExpOp -> (False, SLIT("exp"))
1064 DoubleLogOp -> (False, SLIT("log"))
1065 DoubleSqrtOp -> (False, SLIT("sqrt"))
1067 DoubleSinOp -> (False, SLIT("sin"))
1068 DoubleCosOp -> (False, SLIT("cos"))
1069 DoubleTanOp -> (False, SLIT("tan"))
1071 DoubleAsinOp -> (False, SLIT("asin"))
1072 DoubleAcosOp -> (False, SLIT("acos"))
1073 DoubleAtanOp -> (False, SLIT("atan"))
1075 DoubleSinhOp -> (False, SLIT("sinh"))
1076 DoubleCoshOp -> (False, SLIT("cosh"))
1077 DoubleTanhOp -> (False, SLIT("tanh"))
1080 -> ncgPrimopMoan "getRegister(sparc,monadicprimop)"
1081 (pprStixTree (StPrim primop [x]))
1083 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1085 CharGtOp -> condIntReg GTT x y
1086 CharGeOp -> condIntReg GE x y
1087 CharEqOp -> condIntReg EQQ x y
1088 CharNeOp -> condIntReg NE x y
1089 CharLtOp -> condIntReg LTT x y
1090 CharLeOp -> condIntReg LE x y
1092 IntGtOp -> condIntReg GTT x y
1093 IntGeOp -> condIntReg GE x y
1094 IntEqOp -> condIntReg EQQ x y
1095 IntNeOp -> condIntReg NE x y
1096 IntLtOp -> condIntReg LTT x y
1097 IntLeOp -> condIntReg LE x y
1099 WordGtOp -> condIntReg GU x y
1100 WordGeOp -> condIntReg GEU x y
1101 WordEqOp -> condIntReg EQQ x y
1102 WordNeOp -> condIntReg NE x y
1103 WordLtOp -> condIntReg LU x y
1104 WordLeOp -> condIntReg LEU x y
1106 AddrGtOp -> condIntReg GU x y
1107 AddrGeOp -> condIntReg GEU x y
1108 AddrEqOp -> condIntReg EQQ x y
1109 AddrNeOp -> condIntReg NE x y
1110 AddrLtOp -> condIntReg LU x y
1111 AddrLeOp -> condIntReg LEU x y
1113 FloatGtOp -> condFltReg GTT x y
1114 FloatGeOp -> condFltReg GE x y
1115 FloatEqOp -> condFltReg EQQ x y
1116 FloatNeOp -> condFltReg NE x y
1117 FloatLtOp -> condFltReg LTT x y
1118 FloatLeOp -> condFltReg LE x y
1120 DoubleGtOp -> condFltReg GTT x y
1121 DoubleGeOp -> condFltReg GE x y
1122 DoubleEqOp -> condFltReg EQQ x y
1123 DoubleNeOp -> condFltReg NE x y
1124 DoubleLtOp -> condFltReg LTT x y
1125 DoubleLeOp -> condFltReg LE x y
1127 IntAddOp -> trivialCode (ADD False False) x y
1128 IntSubOp -> trivialCode (SUB False False) x y
1130 -- ToDo: teach about V8+ SPARC mul/div instructions
1131 IntMulOp -> imul_div SLIT(".umul") x y
1132 IntQuotOp -> imul_div SLIT(".div") x y
1133 IntRemOp -> imul_div SLIT(".rem") x y
1135 WordAddOp -> trivialCode (ADD False False) x y
1136 WordSubOp -> trivialCode (SUB False False) x y
1137 WordMulOp -> imul_div SLIT(".umul") x y
1139 FloatAddOp -> trivialFCode FloatRep FADD x y
1140 FloatSubOp -> trivialFCode FloatRep FSUB x y
1141 FloatMulOp -> trivialFCode FloatRep FMUL x y
1142 FloatDivOp -> trivialFCode FloatRep FDIV x y
1144 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1145 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1146 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1147 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1149 AddrAddOp -> trivialCode (ADD False False) x y
1150 AddrSubOp -> trivialCode (SUB False False) x y
1151 AddrRemOp -> imul_div SLIT(".rem") x y
1153 AndOp -> trivialCode (AND False) x y
1154 OrOp -> trivialCode (OR False) x y
1155 XorOp -> trivialCode (XOR False) x y
1156 SllOp -> trivialCode SLL x y
1157 SrlOp -> trivialCode SRL x y
1159 ISllOp -> trivialCode SLL x y
1160 ISraOp -> trivialCode SRA x y
1161 ISrlOp -> trivialCode SRL x y
1163 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1164 [promote x, promote y])
1165 where promote x = StPrim Float2DoubleOp [x]
1166 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1170 -> ncgPrimopMoan "getRegister(sparc,dyadic primop)"
1171 (pprStixTree (StPrim primop [x, y]))
1174 imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1176 getRegister (StInd pk mem)
1177 = getAmode mem `thenNat` \ amode ->
1179 code = amodeCode amode
1180 src = amodeAddr amode
1181 size = primRepToSize pk
1182 code__2 dst = code `snocOL` LD size src dst
1184 returnNat (Any pk code__2)
1186 getRegister (StInt i)
1189 src = ImmInt (fromInteger i)
1190 code dst = unitOL (OR False g0 (RIImm src) dst)
1192 returnNat (Any IntRep code)
1198 SETHI (HI imm__2) dst,
1199 OR False dst (RIImm (LO imm__2)) dst]
1201 returnNat (Any PtrRep code)
1203 = ncgPrimopMoan "getRegister(sparc)" (pprStixTree leaf)
1206 imm__2 = case imm of Just x -> x
1208 #endif {- sparc_TARGET_ARCH -}
1211 %************************************************************************
1213 \subsection{The @Amode@ type}
1215 %************************************************************************
1217 @Amode@s: Memory addressing modes passed up the tree.
1219 data Amode = Amode MachRegsAddr InstrBlock
1221 amodeAddr (Amode addr _) = addr
1222 amodeCode (Amode _ code) = code
1225 Now, given a tree (the argument to an StInd) that references memory,
1226 produce a suitable addressing mode.
1228 A Rule of the Game (tm) for Amodes: use of the addr bit must
1229 immediately follow use of the code part, since the code part puts
1230 values in registers which the addr then refers to. So you can't put
1231 anything in between, lest it overwrite some of those registers. If
1232 you need to do some other computation between the code part and use of
1233 the addr bit, first store the effective address from the amode in a
1234 temporary, then do the other computation, and then use the temporary:
1238 ... other computation ...
1242 getAmode :: StixTree -> NatM Amode
1244 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1246 #if alpha_TARGET_ARCH
1248 getAmode (StPrim IntSubOp [x, StInt i])
1249 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1250 getRegister x `thenNat` \ register ->
1252 code = registerCode register tmp
1253 reg = registerName register tmp
1254 off = ImmInt (-(fromInteger i))
1256 returnNat (Amode (AddrRegImm reg off) code)
1258 getAmode (StPrim IntAddOp [x, StInt i])
1259 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1260 getRegister x `thenNat` \ register ->
1262 code = registerCode register tmp
1263 reg = registerName register tmp
1264 off = ImmInt (fromInteger i)
1266 returnNat (Amode (AddrRegImm reg off) code)
1270 = returnNat (Amode (AddrImm imm__2) id)
1273 imm__2 = case imm of Just x -> x
1276 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1277 getRegister other `thenNat` \ register ->
1279 code = registerCode register tmp
1280 reg = registerName register tmp
1282 returnNat (Amode (AddrReg reg) code)
1284 #endif {- alpha_TARGET_ARCH -}
1285 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1286 #if i386_TARGET_ARCH
1288 getAmode (StPrim IntSubOp [x, StInt i])
1289 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1290 getRegister x `thenNat` \ register ->
1292 code = registerCode register tmp
1293 reg = registerName register tmp
1294 off = ImmInt (-(fromInteger i))
1296 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1298 getAmode (StPrim IntAddOp [x, StInt i])
1300 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1303 imm__2 = case imm of Just x -> x
1305 getAmode (StPrim IntAddOp [x, StInt i])
1306 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1307 getRegister x `thenNat` \ register ->
1309 code = registerCode register tmp
1310 reg = registerName register tmp
1311 off = ImmInt (fromInteger i)
1313 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1315 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1316 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1317 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1318 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1319 getRegister x `thenNat` \ register1 ->
1320 getRegister y `thenNat` \ register2 ->
1322 code1 = registerCode register1 tmp1
1323 reg1 = registerName register1 tmp1
1324 code2 = registerCode register2 tmp2
1325 reg2 = registerName register2 tmp2
1326 code__2 = code1 `appOL` code2
1327 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1329 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1334 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1337 imm__2 = case imm of Just x -> x
1340 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1341 getRegister other `thenNat` \ register ->
1343 code = registerCode register tmp
1344 reg = registerName register tmp
1346 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1348 #endif {- i386_TARGET_ARCH -}
1349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1350 #if sparc_TARGET_ARCH
1352 getAmode (StPrim IntSubOp [x, StInt i])
1354 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1355 getRegister x `thenNat` \ register ->
1357 code = registerCode register tmp
1358 reg = registerName register tmp
1359 off = ImmInt (-(fromInteger i))
1361 returnNat (Amode (AddrRegImm reg off) code)
1364 getAmode (StPrim IntAddOp [x, StInt i])
1366 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1367 getRegister x `thenNat` \ register ->
1369 code = registerCode register tmp
1370 reg = registerName register tmp
1371 off = ImmInt (fromInteger i)
1373 returnNat (Amode (AddrRegImm reg off) code)
1375 getAmode (StPrim IntAddOp [x, y])
1376 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1377 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1378 getRegister x `thenNat` \ register1 ->
1379 getRegister y `thenNat` \ register2 ->
1381 code1 = registerCode register1 tmp1
1382 reg1 = registerName register1 tmp1
1383 code2 = registerCode register2 tmp2
1384 reg2 = registerName register2 tmp2
1385 code__2 = code1 `appOL` code2
1387 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1391 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1393 code = unitOL (SETHI (HI imm__2) tmp)
1395 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1398 imm__2 = case imm of Just x -> x
1401 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1402 getRegister other `thenNat` \ register ->
1404 code = registerCode register tmp
1405 reg = registerName register tmp
1408 returnNat (Amode (AddrRegImm reg off) code)
1410 #endif {- sparc_TARGET_ARCH -}
1413 %************************************************************************
1415 \subsection{The @CondCode@ type}
1417 %************************************************************************
1419 Condition codes passed up the tree.
1421 data CondCode = CondCode Bool Cond InstrBlock
1423 condName (CondCode _ cond _) = cond
1424 condFloat (CondCode is_float _ _) = is_float
1425 condCode (CondCode _ _ code) = code
1428 Set up a condition code for a conditional branch.
1431 getCondCode :: StixTree -> NatM CondCode
1433 #if alpha_TARGET_ARCH
1434 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1435 #endif {- alpha_TARGET_ARCH -}
1436 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1438 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1439 -- yes, they really do seem to want exactly the same!
1441 getCondCode (StPrim primop [x, y])
1443 CharGtOp -> condIntCode GTT x y
1444 CharGeOp -> condIntCode GE x y
1445 CharEqOp -> condIntCode EQQ x y
1446 CharNeOp -> condIntCode NE x y
1447 CharLtOp -> condIntCode LTT x y
1448 CharLeOp -> condIntCode LE x y
1450 IntGtOp -> condIntCode GTT x y
1451 IntGeOp -> condIntCode GE x y
1452 IntEqOp -> condIntCode EQQ x y
1453 IntNeOp -> condIntCode NE x y
1454 IntLtOp -> condIntCode LTT x y
1455 IntLeOp -> condIntCode LE x y
1457 WordGtOp -> condIntCode GU x y
1458 WordGeOp -> condIntCode GEU x y
1459 WordEqOp -> condIntCode EQQ x y
1460 WordNeOp -> condIntCode NE x y
1461 WordLtOp -> condIntCode LU x y
1462 WordLeOp -> condIntCode LEU x y
1464 AddrGtOp -> condIntCode GU x y
1465 AddrGeOp -> condIntCode GEU x y
1466 AddrEqOp -> condIntCode EQQ x y
1467 AddrNeOp -> condIntCode NE x y
1468 AddrLtOp -> condIntCode LU x y
1469 AddrLeOp -> condIntCode LEU x y
1471 FloatGtOp -> condFltCode GTT x y
1472 FloatGeOp -> condFltCode GE x y
1473 FloatEqOp -> condFltCode EQQ x y
1474 FloatNeOp -> condFltCode NE x y
1475 FloatLtOp -> condFltCode LTT x y
1476 FloatLeOp -> condFltCode LE x y
1478 DoubleGtOp -> condFltCode GTT x y
1479 DoubleGeOp -> condFltCode GE x y
1480 DoubleEqOp -> condFltCode EQQ x y
1481 DoubleNeOp -> condFltCode NE x y
1482 DoubleLtOp -> condFltCode LTT x y
1483 DoubleLeOp -> condFltCode LE x y
1485 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1490 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1491 passed back up the tree.
1494 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1496 #if alpha_TARGET_ARCH
1497 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1498 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1499 #endif {- alpha_TARGET_ARCH -}
1501 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1502 #if i386_TARGET_ARCH
1504 -- memory vs immediate
1505 condIntCode cond (StInd pk x) y
1506 | Just i <- maybeImm y
1507 = getAmode x `thenNat` \ amode ->
1509 code1 = amodeCode amode
1510 x__2 = amodeAddr amode
1511 sz = primRepToSize pk
1512 code__2 = code1 `snocOL`
1513 CMP sz (OpImm i) (OpAddr x__2)
1515 returnNat (CondCode False cond code__2)
1518 condIntCode cond x (StInt 0)
1519 = getRegister x `thenNat` \ register1 ->
1520 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1522 code1 = registerCode register1 tmp1
1523 src1 = registerName register1 tmp1
1524 code__2 = code1 `snocOL`
1525 TEST L (OpReg src1) (OpReg src1)
1527 returnNat (CondCode False cond code__2)
1529 -- anything vs immediate
1530 condIntCode cond x y
1531 | Just i <- maybeImm y
1532 = getRegister x `thenNat` \ register1 ->
1533 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1535 code1 = registerCode register1 tmp1
1536 src1 = registerName register1 tmp1
1537 code__2 = code1 `snocOL`
1538 CMP L (OpImm i) (OpReg src1)
1540 returnNat (CondCode False cond code__2)
1542 -- memory vs anything
1543 condIntCode cond (StInd pk x) y
1544 = getAmode x `thenNat` \ amode_x ->
1545 getRegister y `thenNat` \ reg_y ->
1546 getNewRegNCG IntRep `thenNat` \ tmp ->
1548 c_x = amodeCode amode_x
1549 am_x = amodeAddr amode_x
1550 c_y = registerCode reg_y tmp
1551 r_y = registerName reg_y tmp
1552 sz = primRepToSize pk
1554 -- optimisation: if there's no code for x, just an amode,
1555 -- use whatever reg y winds up in. Assumes that c_y doesn't
1556 -- clobber any regs in the amode am_x, which I'm not sure is
1557 -- justified. The otherwise clause makes the same assumption.
1558 code__2 | isNilOL c_x
1560 CMP sz (OpReg r_y) (OpAddr am_x)
1564 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1566 CMP sz (OpReg tmp) (OpAddr am_x)
1568 returnNat (CondCode False cond code__2)
1570 -- anything vs memory
1572 condIntCode cond y (StInd pk x)
1573 = getAmode x `thenNat` \ amode_x ->
1574 getRegister y `thenNat` \ reg_y ->
1575 getNewRegNCG IntRep `thenNat` \ tmp ->
1577 c_x = amodeCode amode_x
1578 am_x = amodeAddr amode_x
1579 c_y = registerCode reg_y tmp
1580 r_y = registerName reg_y tmp
1581 sz = primRepToSize pk
1582 -- same optimisation and nagging doubts as previous clause
1583 code__2 | isNilOL c_x
1585 CMP sz (OpAddr am_x) (OpReg r_y)
1589 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1591 CMP sz (OpAddr am_x) (OpReg tmp)
1593 returnNat (CondCode False cond code__2)
1595 -- anything vs anything
1596 condIntCode cond x y
1597 = getRegister x `thenNat` \ register1 ->
1598 getRegister y `thenNat` \ register2 ->
1599 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1600 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1602 code1 = registerCode register1 tmp1
1603 src1 = registerName register1 tmp1
1604 code2 = registerCode register2 tmp2
1605 src2 = registerName register2 tmp2
1606 code__2 = code1 `snocOL`
1607 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1609 CMP L (OpReg src2) (OpReg tmp1)
1611 returnNat (CondCode False cond code__2)
1614 condFltCode cond x y
1615 = getRegister x `thenNat` \ register1 ->
1616 getRegister y `thenNat` \ register2 ->
1617 getNewRegNCG (registerRep register1)
1619 getNewRegNCG (registerRep register2)
1621 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1623 pk1 = registerRep register1
1624 code1 = registerCode register1 tmp1
1625 src1 = registerName register1 tmp1
1627 code2 = registerCode register2 tmp2
1628 src2 = registerName register2 tmp2
1630 code__2 | isAny register1
1631 = code1 `appOL` -- result in tmp1
1633 GCMP (primRepToSize pk1) tmp1 src2
1637 GMOV src1 tmp1 `appOL`
1639 GCMP (primRepToSize pk1) tmp1 src2
1641 {- On the 486, the flags set by FP compare are the unsigned ones!
1642 (This looks like a HACK to me. WDP 96/03)
1644 fix_FP_cond :: Cond -> Cond
1646 fix_FP_cond GE = GEU
1647 fix_FP_cond GTT = GU
1648 fix_FP_cond LTT = LU
1649 fix_FP_cond LE = LEU
1650 fix_FP_cond any = any
1652 returnNat (CondCode True (fix_FP_cond cond) code__2)
1656 #endif {- i386_TARGET_ARCH -}
1657 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1658 #if sparc_TARGET_ARCH
1660 condIntCode cond x (StInt y)
1662 = getRegister x `thenNat` \ register ->
1663 getNewRegNCG IntRep `thenNat` \ tmp ->
1665 code = registerCode register tmp
1666 src1 = registerName register tmp
1667 src2 = ImmInt (fromInteger y)
1668 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1670 returnNat (CondCode False cond code__2)
1672 condIntCode cond x y
1673 = getRegister x `thenNat` \ register1 ->
1674 getRegister y `thenNat` \ register2 ->
1675 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1676 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1678 code1 = registerCode register1 tmp1
1679 src1 = registerName register1 tmp1
1680 code2 = registerCode register2 tmp2
1681 src2 = registerName register2 tmp2
1682 code__2 = code1 `appOL` code2 `snocOL`
1683 SUB False True src1 (RIReg src2) g0
1685 returnNat (CondCode False cond code__2)
1688 condFltCode cond x y
1689 = getRegister x `thenNat` \ register1 ->
1690 getRegister y `thenNat` \ register2 ->
1691 getNewRegNCG (registerRep register1)
1693 getNewRegNCG (registerRep register2)
1695 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1697 promote x = FxTOy F DF x tmp
1699 pk1 = registerRep register1
1700 code1 = registerCode register1 tmp1
1701 src1 = registerName register1 tmp1
1703 pk2 = registerRep register2
1704 code2 = registerCode register2 tmp2
1705 src2 = registerName register2 tmp2
1709 code1 `appOL` code2 `snocOL`
1710 FCMP True (primRepToSize pk1) src1 src2
1711 else if pk1 == FloatRep then
1712 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1713 FCMP True DF tmp src2
1715 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1716 FCMP True DF src1 tmp
1718 returnNat (CondCode True cond code__2)
1720 #endif {- sparc_TARGET_ARCH -}
1723 %************************************************************************
1725 \subsection{Generating assignments}
1727 %************************************************************************
1729 Assignments are really at the heart of the whole code generation
1730 business. Almost all top-level nodes of any real importance are
1731 assignments, which correspond to loads, stores, or register transfers.
1732 If we're really lucky, some of the register transfers will go away,
1733 because we can use the destination register to complete the code
1734 generation for the right hand side. This only fails when the right
1735 hand side is forced into a fixed register (e.g. the result of a call).
1738 assignIntCode, assignFltCode
1739 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1741 #if alpha_TARGET_ARCH
1743 assignIntCode pk (StInd _ dst) src
1744 = getNewRegNCG IntRep `thenNat` \ tmp ->
1745 getAmode dst `thenNat` \ amode ->
1746 getRegister src `thenNat` \ register ->
1748 code1 = amodeCode amode []
1749 dst__2 = amodeAddr amode
1750 code2 = registerCode register tmp []
1751 src__2 = registerName register tmp
1752 sz = primRepToSize pk
1753 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1757 assignIntCode pk dst src
1758 = getRegister dst `thenNat` \ register1 ->
1759 getRegister src `thenNat` \ register2 ->
1761 dst__2 = registerName register1 zeroh
1762 code = registerCode register2 dst__2
1763 src__2 = registerName register2 dst__2
1764 code__2 = if isFixed register2
1765 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1770 #endif {- alpha_TARGET_ARCH -}
1771 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1772 #if i386_TARGET_ARCH
1774 -- Destination of an assignment can only be reg or mem.
1775 -- This is the mem case.
1776 assignIntCode pk (StInd _ dst) src
1777 = getAmode dst `thenNat` \ amode ->
1778 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1779 getNewRegNCG PtrRep `thenNat` \ tmp ->
1781 -- In general, if the address computation for dst may require
1782 -- some insns preceding the addressing mode itself. So there's
1783 -- no guarantee that the code for dst and the code for src won't
1784 -- write the same register. This means either the address or
1785 -- the value needs to be copied into a temporary. We detect the
1786 -- common case where the amode has no code, and elide the copy.
1787 codea = amodeCode amode
1788 dst__a = amodeAddr amode
1790 code | isNilOL codea
1792 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1796 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1798 MOV (primRepToSize pk) opsrc
1799 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1805 -> NatM (InstrBlock,Operand) -- code, operator
1808 | Just x <- maybeImm op
1809 = returnNat (nilOL, OpImm x)
1812 = getRegister op `thenNat` \ register ->
1813 getNewRegNCG (registerRep register)
1815 let code = registerCode register tmp
1816 reg = registerName register tmp
1818 returnNat (code, OpReg reg)
1820 -- Assign; dst is a reg, rhs is mem
1821 assignIntCode pk dst (StInd pks src)
1822 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1823 getAmode src `thenNat` \ amode ->
1824 getRegister dst `thenNat` \ reg_dst ->
1826 c_addr = amodeCode amode
1827 am_addr = amodeAddr amode
1829 c_dst = registerCode reg_dst tmp -- should be empty
1830 r_dst = registerName reg_dst tmp
1831 szs = primRepToSize pks
1840 code | isNilOL c_dst
1842 opc (OpAddr am_addr) (OpReg r_dst)
1844 = panic "assignIntCode(x86): bad dst(2)"
1848 -- dst is a reg, but src could be anything
1849 assignIntCode pk dst src
1850 = getRegister dst `thenNat` \ registerd ->
1851 getRegister src `thenNat` \ registers ->
1852 getNewRegNCG IntRep `thenNat` \ tmp ->
1854 r_dst = registerName registerd tmp
1855 c_dst = registerCode registerd tmp -- should be empty
1856 r_src = registerName registers r_dst
1857 c_src = registerCode registers r_dst
1859 code | isNilOL c_dst
1861 MOV L (OpReg r_src) (OpReg r_dst)
1863 = panic "assignIntCode(x86): bad dst(3)"
1867 #endif {- i386_TARGET_ARCH -}
1868 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1869 #if sparc_TARGET_ARCH
1871 assignIntCode pk (StInd _ dst) src
1872 = getNewRegNCG IntRep `thenNat` \ tmp ->
1873 getAmode dst `thenNat` \ amode ->
1874 getRegister src `thenNat` \ register ->
1876 code1 = amodeCode amode
1877 dst__2 = amodeAddr amode
1878 code2 = registerCode register tmp
1879 src__2 = registerName register tmp
1880 sz = primRepToSize pk
1881 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1885 assignIntCode pk dst src
1886 = getRegister dst `thenNat` \ register1 ->
1887 getRegister src `thenNat` \ register2 ->
1889 dst__2 = registerName register1 g0
1890 code = registerCode register2 dst__2
1891 src__2 = registerName register2 dst__2
1892 code__2 = if isFixed register2
1893 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1898 #endif {- sparc_TARGET_ARCH -}
1901 % --------------------------------
1902 Floating-point assignments:
1903 % --------------------------------
1905 #if alpha_TARGET_ARCH
1907 assignFltCode pk (StInd _ dst) src
1908 = getNewRegNCG pk `thenNat` \ tmp ->
1909 getAmode dst `thenNat` \ amode ->
1910 getRegister src `thenNat` \ register ->
1912 code1 = amodeCode amode []
1913 dst__2 = amodeAddr amode
1914 code2 = registerCode register tmp []
1915 src__2 = registerName register tmp
1916 sz = primRepToSize pk
1917 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1921 assignFltCode pk dst src
1922 = getRegister dst `thenNat` \ register1 ->
1923 getRegister src `thenNat` \ register2 ->
1925 dst__2 = registerName register1 zeroh
1926 code = registerCode register2 dst__2
1927 src__2 = registerName register2 dst__2
1928 code__2 = if isFixed register2
1929 then code . mkSeqInstr (FMOV src__2 dst__2)
1934 #endif {- alpha_TARGET_ARCH -}
1935 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1936 #if i386_TARGET_ARCH
1939 assignFltCode pk (StInd pk_dst addr) src
1941 = panic "assignFltCode(x86): src/ind sz mismatch"
1943 = getRegister src `thenNat` \ reg_src ->
1944 getRegister addr `thenNat` \ reg_addr ->
1945 getNewRegNCG pk `thenNat` \ tmp_src ->
1946 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1947 let r_src = registerName reg_src tmp_src
1948 c_src = registerCode reg_src tmp_src
1949 r_addr = registerName reg_addr tmp_addr
1950 c_addr = registerCode reg_addr tmp_addr
1951 sz = primRepToSize pk
1953 code = c_src `appOL`
1954 -- no need to preserve r_src across the addr computation,
1955 -- since r_src must be a float reg
1956 -- whilst r_addr is an int reg
1959 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1963 -- dst must be a (FP) register
1964 assignFltCode pk dst src
1965 = getRegister dst `thenNat` \ reg_dst ->
1966 getRegister src `thenNat` \ reg_src ->
1967 getNewRegNCG pk `thenNat` \ tmp ->
1969 r_dst = registerName reg_dst tmp
1970 c_dst = registerCode reg_dst tmp -- should be empty
1972 r_src = registerName reg_src r_dst
1973 c_src = registerCode reg_src r_dst
1975 code | isNilOL c_dst
1976 = if isFixed reg_src
1977 then c_src `snocOL` GMOV r_src r_dst
1980 = panic "assignFltCode(x86): lhs is not mem or reg"
1985 #endif {- i386_TARGET_ARCH -}
1986 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1987 #if sparc_TARGET_ARCH
1989 assignFltCode pk (StInd _ dst) src
1990 = getNewRegNCG pk `thenNat` \ tmp1 ->
1991 getAmode dst `thenNat` \ amode ->
1992 getRegister src `thenNat` \ register ->
1994 sz = primRepToSize pk
1995 dst__2 = amodeAddr amode
1997 code1 = amodeCode amode
1998 code2 = registerCode register tmp1
2000 src__2 = registerName register tmp1
2001 pk__2 = registerRep register
2002 sz__2 = primRepToSize pk__2
2004 code__2 = code1 `appOL` code2 `appOL`
2006 then unitOL (ST sz src__2 dst__2)
2007 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2011 assignFltCode pk dst src
2012 = getRegister dst `thenNat` \ register1 ->
2013 getRegister src `thenNat` \ register2 ->
2015 pk__2 = registerRep register2
2016 sz__2 = primRepToSize pk__2
2018 getNewRegNCG pk__2 `thenNat` \ tmp ->
2020 sz = primRepToSize pk
2021 dst__2 = registerName register1 g0 -- must be Fixed
2024 reg__2 = if pk /= pk__2 then tmp else dst__2
2026 code = registerCode register2 reg__2
2028 src__2 = registerName register2 reg__2
2032 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2033 else if isFixed register2 then
2034 code `snocOL` FMOV sz src__2 dst__2
2040 #endif {- sparc_TARGET_ARCH -}
2043 %************************************************************************
2045 \subsection{Generating an unconditional branch}
2047 %************************************************************************
2049 We accept two types of targets: an immediate CLabel or a tree that
2050 gets evaluated into a register. Any CLabels which are AsmTemporaries
2051 are assumed to be in the local block of code, close enough for a
2052 branch instruction. Other CLabels are assumed to be far away.
2054 (If applicable) Do not fill the delay slots here; you will confuse the
2058 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2060 #if alpha_TARGET_ARCH
2062 genJump (StCLbl lbl)
2063 | isAsmTemp lbl = returnInstr (BR target)
2064 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2066 target = ImmCLbl lbl
2069 = getRegister tree `thenNat` \ register ->
2070 getNewRegNCG PtrRep `thenNat` \ tmp ->
2072 dst = registerName register pv
2073 code = registerCode register pv
2074 target = registerName register pv
2076 if isFixed register then
2077 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2079 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2081 #endif {- alpha_TARGET_ARCH -}
2082 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2083 #if i386_TARGET_ARCH
2085 genJump dsts (StInd pk mem)
2086 = getAmode mem `thenNat` \ amode ->
2088 code = amodeCode amode
2089 target = amodeAddr amode
2091 returnNat (code `snocOL` JMP dsts (OpAddr target))
2095 = returnNat (unitOL (JMP dsts (OpImm target)))
2098 = getRegister tree `thenNat` \ register ->
2099 getNewRegNCG PtrRep `thenNat` \ tmp ->
2101 code = registerCode register tmp
2102 target = registerName register tmp
2104 returnNat (code `snocOL` JMP dsts (OpReg target))
2107 target = case imm of Just x -> x
2109 #endif {- i386_TARGET_ARCH -}
2110 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2111 #if sparc_TARGET_ARCH
2113 genJump dsts (StCLbl lbl)
2114 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2115 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2116 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2118 target = ImmCLbl lbl
2121 = getRegister tree `thenNat` \ register ->
2122 getNewRegNCG PtrRep `thenNat` \ tmp ->
2124 code = registerCode register tmp
2125 target = registerName register tmp
2127 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2129 #endif {- sparc_TARGET_ARCH -}
2132 %************************************************************************
2134 \subsection{Conditional jumps}
2136 %************************************************************************
2138 Conditional jumps are always to local labels, so we can use branch
2139 instructions. We peek at the arguments to decide what kind of
2142 ALPHA: For comparisons with 0, we're laughing, because we can just do
2143 the desired conditional branch.
2145 I386: First, we have to ensure that the condition
2146 codes are set according to the supplied comparison operation.
2148 SPARC: First, we have to ensure that the condition codes are set
2149 according to the supplied comparison operation. We generate slightly
2150 different code for floating point comparisons, because a floating
2151 point operation cannot directly precede a @BF@. We assume the worst
2152 and fill that slot with a @NOP@.
2154 SPARC: Do not fill the delay slots here; you will confuse the register
2159 :: CLabel -- the branch target
2160 -> StixTree -- the condition on which to branch
2163 #if alpha_TARGET_ARCH
2165 genCondJump lbl (StPrim op [x, StInt 0])
2166 = getRegister x `thenNat` \ register ->
2167 getNewRegNCG (registerRep register)
2170 code = registerCode register tmp
2171 value = registerName register tmp
2172 pk = registerRep register
2173 target = ImmCLbl lbl
2175 returnSeq code [BI (cmpOp op) value target]
2177 cmpOp CharGtOp = GTT
2179 cmpOp CharEqOp = EQQ
2181 cmpOp CharLtOp = LTT
2190 cmpOp WordGeOp = ALWAYS
2191 cmpOp WordEqOp = EQQ
2193 cmpOp WordLtOp = NEVER
2194 cmpOp WordLeOp = EQQ
2196 cmpOp AddrGeOp = ALWAYS
2197 cmpOp AddrEqOp = EQQ
2199 cmpOp AddrLtOp = NEVER
2200 cmpOp AddrLeOp = EQQ
2202 genCondJump lbl (StPrim op [x, StDouble 0.0])
2203 = getRegister x `thenNat` \ register ->
2204 getNewRegNCG (registerRep register)
2207 code = registerCode register tmp
2208 value = registerName register tmp
2209 pk = registerRep register
2210 target = ImmCLbl lbl
2212 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2214 cmpOp FloatGtOp = GTT
2215 cmpOp FloatGeOp = GE
2216 cmpOp FloatEqOp = EQQ
2217 cmpOp FloatNeOp = NE
2218 cmpOp FloatLtOp = LTT
2219 cmpOp FloatLeOp = LE
2220 cmpOp DoubleGtOp = GTT
2221 cmpOp DoubleGeOp = GE
2222 cmpOp DoubleEqOp = EQQ
2223 cmpOp DoubleNeOp = NE
2224 cmpOp DoubleLtOp = LTT
2225 cmpOp DoubleLeOp = LE
2227 genCondJump lbl (StPrim op [x, y])
2229 = trivialFCode pr instr x y `thenNat` \ register ->
2230 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2232 code = registerCode register tmp
2233 result = registerName register tmp
2234 target = ImmCLbl lbl
2236 returnNat (code . mkSeqInstr (BF cond result target))
2238 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2240 fltCmpOp op = case op of
2254 (instr, cond) = case op of
2255 FloatGtOp -> (FCMP TF LE, EQQ)
2256 FloatGeOp -> (FCMP TF LTT, EQQ)
2257 FloatEqOp -> (FCMP TF EQQ, NE)
2258 FloatNeOp -> (FCMP TF EQQ, EQQ)
2259 FloatLtOp -> (FCMP TF LTT, NE)
2260 FloatLeOp -> (FCMP TF LE, NE)
2261 DoubleGtOp -> (FCMP TF LE, EQQ)
2262 DoubleGeOp -> (FCMP TF LTT, EQQ)
2263 DoubleEqOp -> (FCMP TF EQQ, NE)
2264 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2265 DoubleLtOp -> (FCMP TF LTT, NE)
2266 DoubleLeOp -> (FCMP TF LE, NE)
2268 genCondJump lbl (StPrim op [x, y])
2269 = trivialCode instr x y `thenNat` \ register ->
2270 getNewRegNCG IntRep `thenNat` \ tmp ->
2272 code = registerCode register tmp
2273 result = registerName register tmp
2274 target = ImmCLbl lbl
2276 returnNat (code . mkSeqInstr (BI cond result target))
2278 (instr, cond) = case op of
2279 CharGtOp -> (CMP LE, EQQ)
2280 CharGeOp -> (CMP LTT, EQQ)
2281 CharEqOp -> (CMP EQQ, NE)
2282 CharNeOp -> (CMP EQQ, EQQ)
2283 CharLtOp -> (CMP LTT, NE)
2284 CharLeOp -> (CMP LE, NE)
2285 IntGtOp -> (CMP LE, EQQ)
2286 IntGeOp -> (CMP LTT, EQQ)
2287 IntEqOp -> (CMP EQQ, NE)
2288 IntNeOp -> (CMP EQQ, EQQ)
2289 IntLtOp -> (CMP LTT, NE)
2290 IntLeOp -> (CMP LE, NE)
2291 WordGtOp -> (CMP ULE, EQQ)
2292 WordGeOp -> (CMP ULT, EQQ)
2293 WordEqOp -> (CMP EQQ, NE)
2294 WordNeOp -> (CMP EQQ, EQQ)
2295 WordLtOp -> (CMP ULT, NE)
2296 WordLeOp -> (CMP ULE, NE)
2297 AddrGtOp -> (CMP ULE, EQQ)
2298 AddrGeOp -> (CMP ULT, EQQ)
2299 AddrEqOp -> (CMP EQQ, NE)
2300 AddrNeOp -> (CMP EQQ, EQQ)
2301 AddrLtOp -> (CMP ULT, NE)
2302 AddrLeOp -> (CMP ULE, NE)
2304 #endif {- alpha_TARGET_ARCH -}
2305 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2306 #if i386_TARGET_ARCH
2308 genCondJump lbl bool
2309 = getCondCode bool `thenNat` \ condition ->
2311 code = condCode condition
2312 cond = condName condition
2314 returnNat (code `snocOL` JXX cond lbl)
2316 #endif {- i386_TARGET_ARCH -}
2317 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2318 #if sparc_TARGET_ARCH
2320 genCondJump lbl bool
2321 = getCondCode bool `thenNat` \ condition ->
2323 code = condCode condition
2324 cond = condName condition
2325 target = ImmCLbl lbl
2330 if condFloat condition
2331 then [NOP, BF cond False target, NOP]
2332 else [BI cond False target, NOP]
2336 #endif {- sparc_TARGET_ARCH -}
2339 %************************************************************************
2341 \subsection{Generating C calls}
2343 %************************************************************************
2345 Now the biggest nightmare---calls. Most of the nastiness is buried in
2346 @get_arg@, which moves the arguments to the correct registers/stack
2347 locations. Apart from that, the code is easy.
2349 (If applicable) Do not fill the delay slots here; you will confuse the
2354 :: FAST_STRING -- function to call
2356 -> PrimRep -- type of the result
2357 -> [StixTree] -- arguments (of mixed type)
2360 #if alpha_TARGET_ARCH
2362 genCCall fn cconv kind args
2363 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2364 `thenNat` \ ((unused,_), argCode) ->
2366 nRegs = length allArgRegs - length unused
2367 code = asmSeqThen (map ($ []) argCode)
2370 LDA pv (AddrImm (ImmLab (ptext fn))),
2371 JSR ra (AddrReg pv) nRegs,
2372 LDGP gp (AddrReg ra)]
2374 ------------------------
2375 {- Try to get a value into a specific register (or registers) for
2376 a call. The first 6 arguments go into the appropriate
2377 argument register (separate registers for integer and floating
2378 point arguments, but used in lock-step), and the remaining
2379 arguments are dumped to the stack, beginning at 0(sp). Our
2380 first argument is a pair of the list of remaining argument
2381 registers to be assigned for this call and the next stack
2382 offset to use for overflowing arguments. This way,
2383 @get_Arg@ can be applied to all of a call's arguments using
2387 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2388 -> StixTree -- Current argument
2389 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2391 -- We have to use up all of our argument registers first...
2393 get_arg ((iDst,fDst):dsts, offset) arg
2394 = getRegister arg `thenNat` \ register ->
2396 reg = if isFloatingRep pk then fDst else iDst
2397 code = registerCode register reg
2398 src = registerName register reg
2399 pk = registerRep register
2402 if isFloatingRep pk then
2403 ((dsts, offset), if isFixed register then
2404 code . mkSeqInstr (FMOV src fDst)
2407 ((dsts, offset), if isFixed register then
2408 code . mkSeqInstr (OR src (RIReg src) iDst)
2411 -- Once we have run out of argument registers, we move to the
2414 get_arg ([], offset) arg
2415 = getRegister arg `thenNat` \ register ->
2416 getNewRegNCG (registerRep register)
2419 code = registerCode register tmp
2420 src = registerName register tmp
2421 pk = registerRep register
2422 sz = primRepToSize pk
2424 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2426 #endif {- alpha_TARGET_ARCH -}
2427 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2428 #if i386_TARGET_ARCH
2430 genCCall fn cconv kind [StInt i]
2431 | fn == SLIT ("PerformGC_wrapper")
2433 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2434 CALL (ImmLit (ptext (if underscorePrefix
2435 then (SLIT ("_PerformGC_wrapper"))
2436 else (SLIT ("PerformGC_wrapper")))))
2442 genCCall fn cconv kind args
2443 = mapNat get_call_arg
2444 (reverse args) `thenNat` \ sizes_n_codes ->
2445 getDeltaNat `thenNat` \ delta ->
2446 let (sizes, codes) = unzip sizes_n_codes
2447 tot_arg_size = sum sizes
2448 code2 = concatOL codes
2450 [CALL (fn__2 tot_arg_size)]
2452 -- Deallocate parameters after call for ccall;
2453 -- but not for stdcall (callee does it)
2454 (if cconv == StdCallConv then [] else
2455 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2458 [DELTA (delta + tot_arg_size)]
2461 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2462 returnNat (code2 `appOL` call)
2465 -- function names that begin with '.' are assumed to be special
2466 -- internally generated names like '.mul,' which don't get an
2467 -- underscore prefix
2468 -- ToDo:needed (WDP 96/03) ???
2472 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2473 | otherwise -- General case
2474 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2476 stdcallsize tot_arg_size
2477 | cconv == StdCallConv = '@':show tot_arg_size
2485 get_call_arg :: StixTree{-current argument-}
2486 -> NatM (Int, InstrBlock) -- argsz, code
2489 = get_op arg `thenNat` \ (code, reg, sz) ->
2490 getDeltaNat `thenNat` \ delta ->
2491 arg_size sz `bind` \ size ->
2492 setDeltaNat (delta-size) `thenNat` \ _ ->
2493 if (case sz of DF -> True; F -> True; _ -> False)
2494 then returnNat (size,
2496 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2498 GST sz reg (AddrBaseIndex (Just esp)
2502 else returnNat (size,
2504 PUSH L (OpReg reg) `snocOL`
2510 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2513 = getRegister op `thenNat` \ register ->
2514 getNewRegNCG (registerRep register)
2517 code = registerCode register tmp
2518 reg = registerName register tmp
2519 pk = registerRep register
2520 sz = primRepToSize pk
2522 returnNat (code, reg, sz)
2524 #endif {- i386_TARGET_ARCH -}
2525 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2526 #if sparc_TARGET_ARCH
2528 The SPARC calling convention is an absolute
2529 nightmare. The first 6x32 bits of arguments are mapped into
2530 %o0 through %o5, and the remaining arguments are dumped to the
2531 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2533 If we have to put args on the stack, move %o6==%sp down by
2534 the number of words to go on the stack, to ensure there's enough space.
2536 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2537 16 words above the stack pointer is a word for the address of
2538 a structure return value. I use this as a temporary location
2539 for moving values from float to int regs. Certainly it isn't
2540 safe to put anything in the 16 words starting at %sp, since
2541 this area can get trashed at any time due to window overflows
2542 caused by signal handlers.
2544 A final complication (if the above isn't enough) is that
2545 we can't blithely calculate the arguments one by one into
2546 %o0 .. %o5. Consider the following nested calls:
2550 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2551 the inner call will itself use %o0, which trashes the value put there
2552 in preparation for the outer call. Upshot: we need to calculate the
2553 args into temporary regs, and move those to arg regs or onto the
2554 stack only immediately prior to the call proper. Sigh.
2557 genCCall fn cconv kind args
2558 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2559 let (argcodes, vregss) = unzip argcode_and_vregs
2560 argcode = concatOL argcodes
2561 vregs = concat vregss
2562 n_argRegs = length allArgRegs
2563 n_argRegs_used = min (length vregs) n_argRegs
2564 (move_sp_down, move_sp_up)
2565 = let nn = length vregs - n_argRegs
2566 + 1 -- (for the road)
2569 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2571 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2573 = unitOL (CALL fn__2 n_argRegs_used False)
2575 returnNat (argcode `appOL`
2576 move_sp_down `appOL`
2577 transfer_code `appOL`
2582 -- function names that begin with '.' are assumed to be special
2583 -- internally generated names like '.mul,' which don't get an
2584 -- underscore prefix
2585 -- ToDo:needed (WDP 96/03) ???
2586 fn__2 = case (_HEAD_ fn) of
2587 '.' -> ImmLit (ptext fn)
2588 _ -> ImmLab False (ptext fn)
2590 -- move args from the integer vregs into which they have been
2591 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2592 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2594 move_final [] _ offset -- all args done
2597 move_final (v:vs) [] offset -- out of aregs; move to stack
2598 = ST W v (spRel offset)
2599 : move_final vs [] (offset+1)
2601 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2602 = OR False g0 (RIReg v) a
2603 : move_final vs az offset
2605 -- generate code to calculate an argument, and move it into one
2606 -- or two integer vregs.
2607 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2608 arg_to_int_vregs arg
2609 = getRegister arg `thenNat` \ register ->
2610 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2611 let code = registerCode register tmp
2612 src = registerName register tmp
2613 pk = registerRep register
2615 -- the value is in src. Get it into 1 or 2 int vregs.
2618 getNewRegNCG WordRep `thenNat` \ v1 ->
2619 getNewRegNCG WordRep `thenNat` \ v2 ->
2622 FMOV DF src f0 `snocOL`
2623 ST F f0 (spRel 16) `snocOL`
2624 LD W (spRel 16) v1 `snocOL`
2625 ST F (fPair f0) (spRel 16) `snocOL`
2631 getNewRegNCG WordRep `thenNat` \ v1 ->
2634 ST F src (spRel 16) `snocOL`
2640 getNewRegNCG WordRep `thenNat` \ v1 ->
2642 code `snocOL` OR False g0 (RIReg src) v1
2646 #endif {- sparc_TARGET_ARCH -}
2649 %************************************************************************
2651 \subsection{Support bits}
2653 %************************************************************************
2655 %************************************************************************
2657 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2659 %************************************************************************
2661 Turn those condition codes into integers now (when they appear on
2662 the right hand side of an assignment).
2664 (If applicable) Do not fill the delay slots here; you will confuse the
2668 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2670 #if alpha_TARGET_ARCH
2671 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2672 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2673 #endif {- alpha_TARGET_ARCH -}
2675 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2676 #if i386_TARGET_ARCH
2679 = condIntCode cond x y `thenNat` \ condition ->
2680 getNewRegNCG IntRep `thenNat` \ tmp ->
2682 code = condCode condition
2683 cond = condName condition
2684 code__2 dst = code `appOL` toOL [
2685 SETCC cond (OpReg tmp),
2686 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2687 MOV L (OpReg tmp) (OpReg dst)]
2689 returnNat (Any IntRep code__2)
2692 = getNatLabelNCG `thenNat` \ lbl1 ->
2693 getNatLabelNCG `thenNat` \ lbl2 ->
2694 condFltCode cond x y `thenNat` \ condition ->
2696 code = condCode condition
2697 cond = condName condition
2698 code__2 dst = code `appOL` toOL [
2700 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2703 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2706 returnNat (Any IntRep code__2)
2708 #endif {- i386_TARGET_ARCH -}
2709 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2710 #if sparc_TARGET_ARCH
2712 condIntReg EQQ x (StInt 0)
2713 = getRegister x `thenNat` \ register ->
2714 getNewRegNCG IntRep `thenNat` \ tmp ->
2716 code = registerCode register tmp
2717 src = registerName register tmp
2718 code__2 dst = code `appOL` toOL [
2719 SUB False True g0 (RIReg src) g0,
2720 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2722 returnNat (Any IntRep code__2)
2725 = getRegister x `thenNat` \ register1 ->
2726 getRegister y `thenNat` \ register2 ->
2727 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2728 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2730 code1 = registerCode register1 tmp1
2731 src1 = registerName register1 tmp1
2732 code2 = registerCode register2 tmp2
2733 src2 = registerName register2 tmp2
2734 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2735 XOR False src1 (RIReg src2) dst,
2736 SUB False True g0 (RIReg dst) g0,
2737 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2739 returnNat (Any IntRep code__2)
2741 condIntReg NE x (StInt 0)
2742 = getRegister x `thenNat` \ register ->
2743 getNewRegNCG IntRep `thenNat` \ tmp ->
2745 code = registerCode register tmp
2746 src = registerName register tmp
2747 code__2 dst = code `appOL` toOL [
2748 SUB False True g0 (RIReg src) g0,
2749 ADD True False g0 (RIImm (ImmInt 0)) dst]
2751 returnNat (Any IntRep code__2)
2754 = getRegister x `thenNat` \ register1 ->
2755 getRegister y `thenNat` \ register2 ->
2756 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2757 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2759 code1 = registerCode register1 tmp1
2760 src1 = registerName register1 tmp1
2761 code2 = registerCode register2 tmp2
2762 src2 = registerName register2 tmp2
2763 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2764 XOR False src1 (RIReg src2) dst,
2765 SUB False True g0 (RIReg dst) g0,
2766 ADD True False g0 (RIImm (ImmInt 0)) dst]
2768 returnNat (Any IntRep code__2)
2771 = getNatLabelNCG `thenNat` \ lbl1 ->
2772 getNatLabelNCG `thenNat` \ lbl2 ->
2773 condIntCode cond x y `thenNat` \ condition ->
2775 code = condCode condition
2776 cond = condName condition
2777 code__2 dst = code `appOL` toOL [
2778 BI cond False (ImmCLbl lbl1), NOP,
2779 OR False g0 (RIImm (ImmInt 0)) dst,
2780 BI ALWAYS False (ImmCLbl lbl2), NOP,
2782 OR False g0 (RIImm (ImmInt 1)) dst,
2785 returnNat (Any IntRep code__2)
2788 = getNatLabelNCG `thenNat` \ lbl1 ->
2789 getNatLabelNCG `thenNat` \ lbl2 ->
2790 condFltCode cond x y `thenNat` \ condition ->
2792 code = condCode condition
2793 cond = condName condition
2794 code__2 dst = code `appOL` toOL [
2796 BF cond False (ImmCLbl lbl1), NOP,
2797 OR False g0 (RIImm (ImmInt 0)) dst,
2798 BI ALWAYS False (ImmCLbl lbl2), NOP,
2800 OR False g0 (RIImm (ImmInt 1)) dst,
2803 returnNat (Any IntRep code__2)
2805 #endif {- sparc_TARGET_ARCH -}
2808 %************************************************************************
2810 \subsubsection{@trivial*Code@: deal with trivial instructions}
2812 %************************************************************************
2814 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2815 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2816 for constants on the right hand side, because that's where the generic
2817 optimizer will have put them.
2819 Similarly, for unary instructions, we don't have to worry about
2820 matching an StInt as the argument, because genericOpt will already
2821 have handled the constant-folding.
2825 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2826 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2827 -> Maybe (Operand -> Operand -> Instr)
2828 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2830 -> StixTree -> StixTree -- the two arguments
2835 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2836 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2837 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2839 -> StixTree -> StixTree -- the two arguments
2843 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2844 ,IF_ARCH_i386 ((Operand -> Instr)
2845 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2847 -> StixTree -- the one argument
2852 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2853 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2854 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2856 -> StixTree -- the one argument
2859 #if alpha_TARGET_ARCH
2861 trivialCode instr x (StInt y)
2863 = getRegister x `thenNat` \ register ->
2864 getNewRegNCG IntRep `thenNat` \ tmp ->
2866 code = registerCode register tmp
2867 src1 = registerName register tmp
2868 src2 = ImmInt (fromInteger y)
2869 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2871 returnNat (Any IntRep code__2)
2873 trivialCode instr x y
2874 = getRegister x `thenNat` \ register1 ->
2875 getRegister y `thenNat` \ register2 ->
2876 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2877 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2879 code1 = registerCode register1 tmp1 []
2880 src1 = registerName register1 tmp1
2881 code2 = registerCode register2 tmp2 []
2882 src2 = registerName register2 tmp2
2883 code__2 dst = asmSeqThen [code1, code2] .
2884 mkSeqInstr (instr src1 (RIReg src2) dst)
2886 returnNat (Any IntRep code__2)
2889 trivialUCode instr x
2890 = getRegister x `thenNat` \ register ->
2891 getNewRegNCG IntRep `thenNat` \ tmp ->
2893 code = registerCode register tmp
2894 src = registerName register tmp
2895 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2897 returnNat (Any IntRep code__2)
2900 trivialFCode _ instr x y
2901 = getRegister x `thenNat` \ register1 ->
2902 getRegister y `thenNat` \ register2 ->
2903 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2904 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2906 code1 = registerCode register1 tmp1
2907 src1 = registerName register1 tmp1
2909 code2 = registerCode register2 tmp2
2910 src2 = registerName register2 tmp2
2912 code__2 dst = asmSeqThen [code1 [], code2 []] .
2913 mkSeqInstr (instr src1 src2 dst)
2915 returnNat (Any DoubleRep code__2)
2917 trivialUFCode _ instr x
2918 = getRegister x `thenNat` \ register ->
2919 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2921 code = registerCode register tmp
2922 src = registerName register tmp
2923 code__2 dst = code . mkSeqInstr (instr src dst)
2925 returnNat (Any DoubleRep code__2)
2927 #endif {- alpha_TARGET_ARCH -}
2928 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2929 #if i386_TARGET_ARCH
2931 The Rules of the Game are:
2933 * You cannot assume anything about the destination register dst;
2934 it may be anything, including a fixed reg.
2936 * You may compute an operand into a fixed reg, but you may not
2937 subsequently change the contents of that fixed reg. If you
2938 want to do so, first copy the value either to a temporary
2939 or into dst. You are free to modify dst even if it happens
2940 to be a fixed reg -- that's not your problem.
2942 * You cannot assume that a fixed reg will stay live over an
2943 arbitrary computation. The same applies to the dst reg.
2945 * Temporary regs obtained from getNewRegNCG are distinct from
2946 each other and from all other regs, and stay live over
2947 arbitrary computations.
2951 trivialCode instr maybe_revinstr a b
2954 = getRegister a `thenNat` \ rega ->
2957 then registerCode rega dst `bind` \ code_a ->
2959 instr (OpImm imm_b) (OpReg dst)
2960 else registerCodeF rega `bind` \ code_a ->
2961 registerNameF rega `bind` \ r_a ->
2963 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2964 instr (OpImm imm_b) (OpReg dst)
2966 returnNat (Any IntRep mkcode)
2969 = getRegister b `thenNat` \ regb ->
2970 getNewRegNCG IntRep `thenNat` \ tmp ->
2971 let revinstr_avail = maybeToBool maybe_revinstr
2972 revinstr = case maybe_revinstr of Just ri -> ri
2976 then registerCode regb dst `bind` \ code_b ->
2978 revinstr (OpImm imm_a) (OpReg dst)
2979 else registerCodeF regb `bind` \ code_b ->
2980 registerNameF regb `bind` \ r_b ->
2982 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2983 revinstr (OpImm imm_a) (OpReg dst)
2987 then registerCode regb tmp `bind` \ code_b ->
2989 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2990 instr (OpReg tmp) (OpReg dst)
2991 else registerCodeF regb `bind` \ code_b ->
2992 registerNameF regb `bind` \ r_b ->
2994 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2995 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2996 instr (OpReg tmp) (OpReg dst)
2998 returnNat (Any IntRep mkcode)
3001 = getRegister a `thenNat` \ rega ->
3002 getRegister b `thenNat` \ regb ->
3003 getNewRegNCG IntRep `thenNat` \ tmp ->
3005 = case (isAny rega, isAny regb) of
3007 -> registerCode regb tmp `bind` \ code_b ->
3008 registerCode rega dst `bind` \ code_a ->
3011 instr (OpReg tmp) (OpReg dst)
3013 -> registerCode rega tmp `bind` \ code_a ->
3014 registerCodeF regb `bind` \ code_b ->
3015 registerNameF regb `bind` \ r_b ->
3018 instr (OpReg r_b) (OpReg tmp) `snocOL`
3019 MOV L (OpReg tmp) (OpReg dst)
3021 -> registerCode regb tmp `bind` \ code_b ->
3022 registerCodeF rega `bind` \ code_a ->
3023 registerNameF rega `bind` \ r_a ->
3026 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3027 instr (OpReg tmp) (OpReg dst)
3029 -> registerCodeF rega `bind` \ code_a ->
3030 registerNameF rega `bind` \ r_a ->
3031 registerCodeF regb `bind` \ code_b ->
3032 registerNameF regb `bind` \ r_b ->
3034 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3036 instr (OpReg r_b) (OpReg tmp) `snocOL`
3037 MOV L (OpReg tmp) (OpReg dst)
3039 returnNat (Any IntRep mkcode)
3042 maybe_imm_a = maybeImm a
3043 is_imm_a = maybeToBool maybe_imm_a
3044 imm_a = case maybe_imm_a of Just imm -> imm
3046 maybe_imm_b = maybeImm b
3047 is_imm_b = maybeToBool maybe_imm_b
3048 imm_b = case maybe_imm_b of Just imm -> imm
3052 trivialUCode instr x
3053 = getRegister x `thenNat` \ register ->
3055 code__2 dst = let code = registerCode register dst
3056 src = registerName register dst
3058 if isFixed register && dst /= src
3059 then toOL [MOV L (OpReg src) (OpReg dst),
3061 else unitOL (instr (OpReg src))
3063 returnNat (Any IntRep code__2)
3066 trivialFCode pk instr x y
3067 = getRegister x `thenNat` \ register1 ->
3068 getRegister y `thenNat` \ register2 ->
3069 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3070 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3072 code1 = registerCode register1 tmp1
3073 src1 = registerName register1 tmp1
3075 code2 = registerCode register2 tmp2
3076 src2 = registerName register2 tmp2
3079 -- treat the common case specially: both operands in
3081 | isAny register1 && isAny register2
3084 instr (primRepToSize pk) src1 src2 dst
3086 -- be paranoid (and inefficient)
3088 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3090 instr (primRepToSize pk) tmp1 src2 dst
3092 returnNat (Any pk code__2)
3096 trivialUFCode pk instr x
3097 = getRegister x `thenNat` \ register ->
3098 getNewRegNCG pk `thenNat` \ tmp ->
3100 code = registerCode register tmp
3101 src = registerName register tmp
3102 code__2 dst = code `snocOL` instr src dst
3104 returnNat (Any pk code__2)
3106 #endif {- i386_TARGET_ARCH -}
3107 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3108 #if sparc_TARGET_ARCH
3110 trivialCode instr x (StInt y)
3112 = getRegister x `thenNat` \ register ->
3113 getNewRegNCG IntRep `thenNat` \ tmp ->
3115 code = registerCode register tmp
3116 src1 = registerName register tmp
3117 src2 = ImmInt (fromInteger y)
3118 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3120 returnNat (Any IntRep code__2)
3122 trivialCode instr x y
3123 = getRegister x `thenNat` \ register1 ->
3124 getRegister y `thenNat` \ register2 ->
3125 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3126 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3128 code1 = registerCode register1 tmp1
3129 src1 = registerName register1 tmp1
3130 code2 = registerCode register2 tmp2
3131 src2 = registerName register2 tmp2
3132 code__2 dst = code1 `appOL` code2 `snocOL`
3133 instr src1 (RIReg src2) dst
3135 returnNat (Any IntRep code__2)
3138 trivialFCode pk instr x y
3139 = getRegister x `thenNat` \ register1 ->
3140 getRegister y `thenNat` \ register2 ->
3141 getNewRegNCG (registerRep register1)
3143 getNewRegNCG (registerRep register2)
3145 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3147 promote x = FxTOy F DF x tmp
3149 pk1 = registerRep register1
3150 code1 = registerCode register1 tmp1
3151 src1 = registerName register1 tmp1
3153 pk2 = registerRep register2
3154 code2 = registerCode register2 tmp2
3155 src2 = registerName register2 tmp2
3159 code1 `appOL` code2 `snocOL`
3160 instr (primRepToSize pk) src1 src2 dst
3161 else if pk1 == FloatRep then
3162 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3163 instr DF tmp src2 dst
3165 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3166 instr DF src1 tmp dst
3168 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3171 trivialUCode instr x
3172 = getRegister x `thenNat` \ register ->
3173 getNewRegNCG IntRep `thenNat` \ tmp ->
3175 code = registerCode register tmp
3176 src = registerName register tmp
3177 code__2 dst = code `snocOL` instr (RIReg src) dst
3179 returnNat (Any IntRep code__2)
3182 trivialUFCode pk instr x
3183 = getRegister x `thenNat` \ register ->
3184 getNewRegNCG pk `thenNat` \ tmp ->
3186 code = registerCode register tmp
3187 src = registerName register tmp
3188 code__2 dst = code `snocOL` instr src dst
3190 returnNat (Any pk code__2)
3192 #endif {- sparc_TARGET_ARCH -}
3195 %************************************************************************
3197 \subsubsection{Coercing to/from integer/floating-point...}
3199 %************************************************************************
3201 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3202 to be generated. Here we just change the type on the Register passed
3203 on up. The code is machine-independent.
3205 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3206 conversions. We have to store temporaries in memory to move
3207 between the integer and the floating point register sets.
3210 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3211 coerceFltCode :: StixTree -> NatM Register
3213 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3214 coerceFP2Int :: StixTree -> NatM Register
3217 = getRegister x `thenNat` \ register ->
3220 Fixed _ reg code -> Fixed pk reg code
3221 Any _ code -> Any pk code
3226 = getRegister x `thenNat` \ register ->
3229 Fixed _ reg code -> Fixed DoubleRep reg code
3230 Any _ code -> Any DoubleRep code
3235 #if alpha_TARGET_ARCH
3238 = getRegister x `thenNat` \ register ->
3239 getNewRegNCG IntRep `thenNat` \ reg ->
3241 code = registerCode register reg
3242 src = registerName register reg
3244 code__2 dst = code . mkSeqInstrs [
3246 LD TF dst (spRel 0),
3249 returnNat (Any DoubleRep code__2)
3253 = getRegister x `thenNat` \ register ->
3254 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3256 code = registerCode register tmp
3257 src = registerName register tmp
3259 code__2 dst = code . mkSeqInstrs [
3261 ST TF tmp (spRel 0),
3264 returnNat (Any IntRep code__2)
3266 #endif {- alpha_TARGET_ARCH -}
3267 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3268 #if i386_TARGET_ARCH
3271 = getRegister x `thenNat` \ register ->
3272 getNewRegNCG IntRep `thenNat` \ reg ->
3274 code = registerCode register reg
3275 src = registerName register reg
3276 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3277 code__2 dst = code `snocOL` opc src dst
3279 returnNat (Any pk code__2)
3283 = getRegister x `thenNat` \ register ->
3284 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3286 code = registerCode register tmp
3287 src = registerName register tmp
3288 pk = registerRep register
3290 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3291 code__2 dst = code `snocOL` opc src dst
3293 returnNat (Any IntRep code__2)
3295 #endif {- i386_TARGET_ARCH -}
3296 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3297 #if sparc_TARGET_ARCH
3300 = getRegister x `thenNat` \ register ->
3301 getNewRegNCG IntRep `thenNat` \ reg ->
3303 code = registerCode register reg
3304 src = registerName register reg
3306 code__2 dst = code `appOL` toOL [
3307 ST W src (spRel (-2)),
3308 LD W (spRel (-2)) dst,
3309 FxTOy W (primRepToSize pk) dst dst]
3311 returnNat (Any pk code__2)
3315 = getRegister x `thenNat` \ register ->
3316 getNewRegNCG IntRep `thenNat` \ reg ->
3317 getNewRegNCG FloatRep `thenNat` \ tmp ->
3319 code = registerCode register reg
3320 src = registerName register reg
3321 pk = registerRep register
3323 code__2 dst = code `appOL` toOL [
3324 FxTOy (primRepToSize pk) W src tmp,
3325 ST W tmp (spRel (-2)),
3326 LD W (spRel (-2)) dst]
3328 returnNat (Any IntRep code__2)
3330 #endif {- sparc_TARGET_ARCH -}
3333 %************************************************************************
3335 \subsubsection{Coercing integer to @Char@...}
3337 %************************************************************************
3339 Integer to character conversion.
3342 chrCode :: StixTree -> NatM Register
3344 #if alpha_TARGET_ARCH
3346 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3347 -- It should coerce a 64-bit value to a 32-bit value.
3350 = getRegister x `thenNat` \ register ->
3351 getNewRegNCG IntRep `thenNat` \ reg ->
3353 code = registerCode register reg
3354 src = registerName register reg
3355 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3357 returnNat (Any IntRep code__2)
3359 #endif {- alpha_TARGET_ARCH -}
3360 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3361 #if i386_TARGET_ARCH
3364 = getRegister x `thenNat` \ register ->
3367 Fixed _ reg code -> Fixed IntRep reg code
3368 Any _ code -> Any IntRep code
3371 #endif {- i386_TARGET_ARCH -}
3372 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3373 #if sparc_TARGET_ARCH
3376 = getRegister x `thenNat` \ register ->
3379 Fixed _ reg code -> Fixed IntRep reg code
3380 Any _ code -> Any IntRep code
3383 #endif {- sparc_TARGET_ARCH -}