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 ( isAsmTemp, CLabel, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import Stix ( getNatLabelNCG, StixTree(..),
28 StixReg(..), CodeSegment(..),
29 DestInfo, hasDestInfo,
31 NatM, thenNat, returnNat, mapNat,
32 mapAndUnzipNat, mapAccumLNat,
33 getDeltaNat, setDeltaNat
36 import CmdLineOpts ( opt_Static )
42 @InstrBlock@s are the insn sequences generated by the insn selectors.
43 They are really trees of insns to facilitate fast appending, where a
44 left-to-right traversal (pre-order?) yields the insns in the correct
49 type InstrBlock = OrdList Instr
55 Code extractor for an entire stix tree---stix statement level.
58 stmtsToInstrs :: [StixTree] -> NatM InstrBlock
60 = liftStrings stmts [] [] `thenNat` \ lifted ->
61 mapNat stmtToInstrs lifted `thenNat` \ instrss ->
62 returnNat (concatOL instrss)
65 -- Lift StStrings out of top-level StDatas, putting them at the end of
66 -- the block, and replacing them with StCLbls which refer to the lifted-out strings.
67 {- Motivation for this hackery provided by the following bug:
71 (Data P_ Addr.A#_static_info)
72 (Data StgAddr (Str `alalal'))
77 .global Bogon_ping_closure
79 .long Addr_Azh_static_info
90 ie, the Str is planted in-line, when what we really meant was to place
91 a _reference_ to the string there. liftStrings will lift out all such
92 strings in top-level data and place them at the end of the block.
94 This is still a rather half-baked solution -- to do the job entirely right
95 would mean a complete traversal of all the Stixes, but there's currently no
96 real need for it, and it would be slow. Also, potentially there could be
97 literal types other than strings which need lifting out?
100 liftStrings :: [StixTree] -- originals
101 -> [StixTree] -- (reverse) originals with strings lifted out
102 -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels
105 -- First, examine the original trees and lift out strings in top-level StDatas.
106 liftStrings (st:sts) acc_stix acc_strs
109 -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) ->
110 liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
112 -> liftStrings sts (other:acc_stix) acc_strs
114 -- Handle a top-level StData
115 lift [] acc_strs = returnNat ([], acc_strs)
117 = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) ->
120 -> getNatLabelNCG `thenNat` \ lbl ->
121 returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
123 -> returnNat (other:ds_done, acc_strs1)
125 -- When we've run out of original trees, emit the lifted strings.
126 liftStrings [] acc_stix acc_strs
127 = returnNat (reverse acc_stix ++ concatMap f acc_strs)
129 f (lbl,str) = [StSegment RoDataSegment,
132 StSegment TextSegment]
135 stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
136 stmtToInstrs stmt = case stmt of
137 StComment s -> returnNat (unitOL (COMMENT s))
138 StSegment seg -> returnNat (unitOL (SEGMENT seg))
140 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
142 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
145 StLabel lab -> returnNat (unitOL (LABEL lab))
147 StJump dsts arg -> genJump dsts (derefDLL arg)
148 StCondJump lab arg -> genCondJump lab (derefDLL arg)
150 -- A call returning void, ie one done for its side-effects
151 StCall fn cconv VoidRep args -> genCCall fn
152 cconv VoidRep (map derefDLL args)
155 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
156 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
159 -- When falling through on the Alpha, we still have to load pv
160 -- with the address of the next routine, so that it can load gp.
161 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
165 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
166 returnNat (DATA (primRepToSize kind) imms
167 `consOL` concatOL codes)
169 getData :: StixTree -> NatM (InstrBlock, Imm)
170 getData (StInt i) = returnNat (nilOL, ImmInteger i)
171 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
172 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
173 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
174 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
175 -- the linker can handle simple arithmetic...
176 getData (StIndex rep (StCLbl lbl) (StInt off)) =
178 ImmIndex lbl (fromInteger off * sizeOf rep))
180 -- Top-level lifted-out string. The segment will already have been set
181 -- (see liftStrings above).
183 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
186 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
187 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
188 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
190 derefDLL :: StixTree -> StixTree
192 | opt_Static -- short out the entire deal if not doing DLLs
199 StCLbl lbl -> if labelDynamic lbl
200 then StInd PtrRep (StCLbl lbl)
202 -- all the rest are boring
203 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
204 StPrim pk args -> StPrim pk (map qq args)
205 StInd pk addr -> StInd pk (qq addr)
206 StCall who cc pk args -> StCall who cc pk (map qq args)
213 _ -> pprPanic "derefDLL: unhandled case"
217 %************************************************************************
219 \subsection{General things for putting together code sequences}
221 %************************************************************************
224 mangleIndexTree :: StixTree -> StixTree
226 mangleIndexTree (StIndex pk base (StInt i))
227 = StPrim IntAddOp [base, off]
229 off = StInt (i * toInteger (sizeOf pk))
231 mangleIndexTree (StIndex pk base off)
235 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
238 shift :: PrimRep -> Int
239 shift rep = case sizeOf rep of
244 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
249 maybeImm :: StixTree -> Maybe Imm
253 maybeImm (StIndex rep (StCLbl l) (StInt off))
254 = Just (ImmIndex l (fromInteger off * sizeOf rep))
256 | i >= toInteger minInt && i <= toInteger maxInt
257 = Just (ImmInt (fromInteger i))
259 = Just (ImmInteger i)
264 %************************************************************************
266 \subsection{The @Register@ type}
268 %************************************************************************
270 @Register@s passed up the tree. If the stix code forces the register
271 to live in a pre-decided machine register, it comes out as @Fixed@;
272 otherwise, it comes out as @Any@, and the parent can decide which
273 register to put it in.
277 = Fixed PrimRep Reg InstrBlock
278 | Any PrimRep (Reg -> InstrBlock)
280 registerCode :: Register -> Reg -> InstrBlock
281 registerCode (Fixed _ _ code) reg = code
282 registerCode (Any _ code) reg = code reg
284 registerCodeF (Fixed _ _ code) = code
285 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
287 registerCodeA (Any _ code) = code
288 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
290 registerName :: Register -> Reg -> Reg
291 registerName (Fixed _ reg _) _ = reg
292 registerName (Any _ _) reg = reg
294 registerNameF (Fixed _ reg _) = reg
295 registerNameF (Any _ _) = pprPanic "registerNameF" empty
297 registerRep :: Register -> PrimRep
298 registerRep (Fixed pk _ _) = pk
299 registerRep (Any pk _) = pk
301 {-# INLINE registerCode #-}
302 {-# INLINE registerCodeF #-}
303 {-# INLINE registerName #-}
304 {-# INLINE registerNameF #-}
305 {-# INLINE registerRep #-}
306 {-# INLINE isFixed #-}
309 isFixed, isAny :: Register -> Bool
310 isFixed (Fixed _ _ _) = True
311 isFixed (Any _ _) = False
313 isAny = not . isFixed
316 Generate code to get a subtree into a @Register@:
318 getRegister :: StixTree -> NatM Register
320 getRegister (StReg (StixMagicId stgreg))
321 = case (magicIdRegMaybe stgreg) of
322 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
325 getRegister (StReg (StixTemp u pk))
326 = returnNat (Fixed pk (mkVReg u pk) nilOL)
328 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
330 getRegister (StCall fn cconv kind args)
331 = genCCall fn cconv kind args `thenNat` \ call ->
332 returnNat (Fixed kind reg call)
334 reg = if isFloatingRep kind
335 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
336 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
338 getRegister (StString s)
339 = getNatLabelNCG `thenNat` \ lbl ->
341 imm_lbl = ImmCLbl lbl
344 SEGMENT RoDataSegment,
346 ASCII True (_UNPK_ s),
348 #if alpha_TARGET_ARCH
349 LDA dst (AddrImm imm_lbl)
352 MOV L (OpImm imm_lbl) (OpReg dst)
354 #if sparc_TARGET_ARCH
355 SETHI (HI imm_lbl) dst,
356 OR False dst (RIImm (LO imm_lbl)) dst
360 returnNat (Any PtrRep code)
364 -- end of machine-"independent" bit; here we go on the rest...
366 #if alpha_TARGET_ARCH
368 getRegister (StDouble d)
369 = getNatLabelNCG `thenNat` \ lbl ->
370 getNewRegNCG PtrRep `thenNat` \ tmp ->
371 let code dst = mkSeqInstrs [
374 DATA TF [ImmLab (rational d)],
376 LDA tmp (AddrImm (ImmCLbl lbl)),
377 LD TF dst (AddrReg tmp)]
379 returnNat (Any DoubleRep code)
381 getRegister (StPrim primop [x]) -- unary PrimOps
383 IntNegOp -> trivialUCode (NEG Q False) x
385 NotOp -> trivialUCode NOT x
387 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
388 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
390 OrdOp -> coerceIntCode IntRep x
393 Float2IntOp -> coerceFP2Int x
394 Int2FloatOp -> coerceInt2FP pr x
395 Double2IntOp -> coerceFP2Int x
396 Int2DoubleOp -> coerceInt2FP pr x
398 Double2FloatOp -> coerceFltCode x
399 Float2DoubleOp -> coerceFltCode x
401 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
403 fn = case other_op of
404 FloatExpOp -> SLIT("exp")
405 FloatLogOp -> SLIT("log")
406 FloatSqrtOp -> SLIT("sqrt")
407 FloatSinOp -> SLIT("sin")
408 FloatCosOp -> SLIT("cos")
409 FloatTanOp -> SLIT("tan")
410 FloatAsinOp -> SLIT("asin")
411 FloatAcosOp -> SLIT("acos")
412 FloatAtanOp -> SLIT("atan")
413 FloatSinhOp -> SLIT("sinh")
414 FloatCoshOp -> SLIT("cosh")
415 FloatTanhOp -> SLIT("tanh")
416 DoubleExpOp -> SLIT("exp")
417 DoubleLogOp -> SLIT("log")
418 DoubleSqrtOp -> SLIT("sqrt")
419 DoubleSinOp -> SLIT("sin")
420 DoubleCosOp -> SLIT("cos")
421 DoubleTanOp -> SLIT("tan")
422 DoubleAsinOp -> SLIT("asin")
423 DoubleAcosOp -> SLIT("acos")
424 DoubleAtanOp -> SLIT("atan")
425 DoubleSinhOp -> SLIT("sinh")
426 DoubleCoshOp -> SLIT("cosh")
427 DoubleTanhOp -> SLIT("tanh")
429 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
431 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
433 CharGtOp -> trivialCode (CMP LTT) y x
434 CharGeOp -> trivialCode (CMP LE) y x
435 CharEqOp -> trivialCode (CMP EQQ) x y
436 CharNeOp -> int_NE_code x y
437 CharLtOp -> trivialCode (CMP LTT) x y
438 CharLeOp -> trivialCode (CMP LE) x y
440 IntGtOp -> trivialCode (CMP LTT) y x
441 IntGeOp -> trivialCode (CMP LE) y x
442 IntEqOp -> trivialCode (CMP EQQ) x y
443 IntNeOp -> int_NE_code x y
444 IntLtOp -> trivialCode (CMP LTT) x y
445 IntLeOp -> trivialCode (CMP LE) x y
447 WordGtOp -> trivialCode (CMP ULT) y x
448 WordGeOp -> trivialCode (CMP ULE) x y
449 WordEqOp -> trivialCode (CMP EQQ) x y
450 WordNeOp -> int_NE_code x y
451 WordLtOp -> trivialCode (CMP ULT) x y
452 WordLeOp -> trivialCode (CMP ULE) x y
454 AddrGtOp -> trivialCode (CMP ULT) y x
455 AddrGeOp -> trivialCode (CMP ULE) y x
456 AddrEqOp -> trivialCode (CMP EQQ) x y
457 AddrNeOp -> int_NE_code x y
458 AddrLtOp -> trivialCode (CMP ULT) x y
459 AddrLeOp -> trivialCode (CMP ULE) x y
461 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
462 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
463 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
464 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
465 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
466 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
468 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
469 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
470 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
471 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
472 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
473 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
475 IntAddOp -> trivialCode (ADD Q False) x y
476 IntSubOp -> trivialCode (SUB Q False) x y
477 IntMulOp -> trivialCode (MUL Q False) x y
478 IntQuotOp -> trivialCode (DIV Q False) x y
479 IntRemOp -> trivialCode (REM Q False) x y
481 WordAddOp -> trivialCode (ADD Q False) x y
482 WordSubOp -> trivialCode (SUB Q False) x y
483 WordMulOp -> trivialCode (MUL Q False) x y
484 WordQuotOp -> trivialCode (DIV Q True) x y
485 WordRemOp -> trivialCode (REM Q True) x y
487 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
488 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
489 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
490 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
492 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
493 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
494 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
495 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
497 AndOp -> trivialCode AND x y
498 OrOp -> trivialCode OR x y
499 XorOp -> trivialCode XOR x y
500 SllOp -> trivialCode SLL x y
501 SrlOp -> trivialCode SRL x y
503 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
504 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
505 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
507 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
508 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
510 {- ------------------------------------------------------------
511 Some bizarre special code for getting condition codes into
512 registers. Integer non-equality is a test for equality
513 followed by an XOR with 1. (Integer comparisons always set
514 the result register to 0 or 1.) Floating point comparisons of
515 any kind leave the result in a floating point register, so we
516 need to wrangle an integer register out of things.
518 int_NE_code :: StixTree -> StixTree -> NatM Register
521 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
522 getNewRegNCG IntRep `thenNat` \ tmp ->
524 code = registerCode register tmp
525 src = registerName register tmp
526 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
528 returnNat (Any IntRep code__2)
530 {- ------------------------------------------------------------
531 Comments for int_NE_code also apply to cmpF_code
534 :: (Reg -> Reg -> Reg -> Instr)
536 -> StixTree -> StixTree
539 cmpF_code instr cond x y
540 = trivialFCode pr instr x y `thenNat` \ register ->
541 getNewRegNCG DoubleRep `thenNat` \ tmp ->
542 getNatLabelNCG `thenNat` \ lbl ->
544 code = registerCode register tmp
545 result = registerName register tmp
547 code__2 dst = code . mkSeqInstrs [
548 OR zeroh (RIImm (ImmInt 1)) dst,
549 BF cond result (ImmCLbl lbl),
550 OR zeroh (RIReg zeroh) dst,
553 returnNat (Any IntRep code__2)
555 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
556 ------------------------------------------------------------
558 getRegister (StInd pk mem)
559 = getAmode mem `thenNat` \ amode ->
561 code = amodeCode amode
562 src = amodeAddr amode
563 size = primRepToSize pk
564 code__2 dst = code . mkSeqInstr (LD size dst src)
566 returnNat (Any pk code__2)
568 getRegister (StInt i)
571 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
573 returnNat (Any IntRep code)
576 code dst = mkSeqInstr (LDI Q dst src)
578 returnNat (Any IntRep code)
580 src = ImmInt (fromInteger i)
585 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
587 returnNat (Any PtrRep code)
590 imm__2 = case imm of Just x -> x
592 #endif {- alpha_TARGET_ARCH -}
593 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
596 getRegister (StFloat f)
597 = getNatLabelNCG `thenNat` \ lbl ->
598 let code dst = toOL [
603 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
606 returnNat (Any FloatRep code)
609 getRegister (StDouble d)
612 = let code dst = unitOL (GLDZ dst)
613 in returnNat (Any DoubleRep code)
616 = let code dst = unitOL (GLD1 dst)
617 in returnNat (Any DoubleRep code)
620 = getNatLabelNCG `thenNat` \ lbl ->
621 let code dst = toOL [
624 DATA DF [ImmDouble d],
626 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
629 returnNat (Any DoubleRep code)
631 -- Calculate the offset for (i+1) words above the _initial_
632 -- %esp value by first determining the current offset of it.
633 getRegister (StScratchWord i)
635 = getDeltaNat `thenNat` \ current_stack_offset ->
636 let j = i+1 - (current_stack_offset `div` 4)
638 = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
640 returnNat (Any PtrRep code)
642 getRegister (StPrim primop [x]) -- unary PrimOps
644 IntNegOp -> trivialUCode (NEGI L) x
645 NotOp -> trivialUCode (NOT L) x
647 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
648 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
650 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
651 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
653 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
654 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
656 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
657 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
659 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
660 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
662 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
663 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
665 OrdOp -> coerceIntCode IntRep x
668 Float2IntOp -> coerceFP2Int x
669 Int2FloatOp -> coerceInt2FP FloatRep x
670 Double2IntOp -> coerceFP2Int x
671 Int2DoubleOp -> coerceInt2FP DoubleRep x
674 getRegister (StCall fn CCallConv DoubleRep [x])
678 FloatExpOp -> (True, SLIT("exp"))
679 FloatLogOp -> (True, SLIT("log"))
681 FloatAsinOp -> (True, SLIT("asin"))
682 FloatAcosOp -> (True, SLIT("acos"))
683 FloatAtanOp -> (True, SLIT("atan"))
685 FloatSinhOp -> (True, SLIT("sinh"))
686 FloatCoshOp -> (True, SLIT("cosh"))
687 FloatTanhOp -> (True, SLIT("tanh"))
689 DoubleExpOp -> (False, SLIT("exp"))
690 DoubleLogOp -> (False, SLIT("log"))
692 DoubleAsinOp -> (False, SLIT("asin"))
693 DoubleAcosOp -> (False, SLIT("acos"))
694 DoubleAtanOp -> (False, SLIT("atan"))
696 DoubleSinhOp -> (False, SLIT("sinh"))
697 DoubleCoshOp -> (False, SLIT("cosh"))
698 DoubleTanhOp -> (False, SLIT("tanh"))
701 -> pprPanic "getRegister(x86,unary primop)"
702 (pprStixTree (StPrim primop [x]))
704 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
706 CharGtOp -> condIntReg GTT x y
707 CharGeOp -> condIntReg GE x y
708 CharEqOp -> condIntReg EQQ x y
709 CharNeOp -> condIntReg NE x y
710 CharLtOp -> condIntReg LTT x y
711 CharLeOp -> condIntReg LE x y
713 IntGtOp -> condIntReg GTT x y
714 IntGeOp -> condIntReg GE x y
715 IntEqOp -> condIntReg EQQ x y
716 IntNeOp -> condIntReg NE x y
717 IntLtOp -> condIntReg LTT x y
718 IntLeOp -> condIntReg LE x y
720 WordGtOp -> condIntReg GU x y
721 WordGeOp -> condIntReg GEU x y
722 WordEqOp -> condIntReg EQQ x y
723 WordNeOp -> condIntReg NE x y
724 WordLtOp -> condIntReg LU x y
725 WordLeOp -> condIntReg LEU x y
727 AddrGtOp -> condIntReg GU x y
728 AddrGeOp -> condIntReg GEU x y
729 AddrEqOp -> condIntReg EQQ x y
730 AddrNeOp -> condIntReg NE x y
731 AddrLtOp -> condIntReg LU x y
732 AddrLeOp -> condIntReg LEU x y
734 FloatGtOp -> condFltReg GTT x y
735 FloatGeOp -> condFltReg GE x y
736 FloatEqOp -> condFltReg EQQ x y
737 FloatNeOp -> condFltReg NE x y
738 FloatLtOp -> condFltReg LTT x y
739 FloatLeOp -> condFltReg LE x y
741 DoubleGtOp -> condFltReg GTT x y
742 DoubleGeOp -> condFltReg GE x y
743 DoubleEqOp -> condFltReg EQQ x y
744 DoubleNeOp -> condFltReg NE x y
745 DoubleLtOp -> condFltReg LTT x y
746 DoubleLeOp -> condFltReg LE x y
748 IntAddOp -> add_code L x y
749 IntSubOp -> sub_code L x y
750 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
751 IntRemOp -> trivialCode (IREM L) Nothing x y
752 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
754 WordAddOp -> add_code L x y
755 WordSubOp -> sub_code L x y
756 WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y
758 FloatAddOp -> trivialFCode FloatRep GADD x y
759 FloatSubOp -> trivialFCode FloatRep GSUB x y
760 FloatMulOp -> trivialFCode FloatRep GMUL x y
761 FloatDivOp -> trivialFCode FloatRep GDIV x y
763 DoubleAddOp -> trivialFCode DoubleRep GADD x y
764 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
765 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
766 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
768 AndOp -> let op = AND L in trivialCode op (Just op) x y
769 OrOp -> let op = OR L in trivialCode op (Just op) x y
770 XorOp -> let op = XOR L in trivialCode op (Just op) x y
772 {- Shift ops on x86s have constraints on their source, it
773 either has to be Imm, CL or 1
774 => trivialCode's is not restrictive enough (sigh.)
777 SllOp -> shift_code (SHL L) x y {-False-}
778 SrlOp -> shift_code (SHR L) x y {-False-}
779 ISllOp -> shift_code (SHL L) x y {-False-}
780 ISraOp -> shift_code (SAR L) x y {-False-}
781 ISrlOp -> shift_code (SHR L) x y {-False-}
783 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
784 [promote x, promote y])
785 where promote x = StPrim Float2DoubleOp [x]
786 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
789 -> pprPanic "getRegister(x86,dyadic primop)"
790 (pprStixTree (StPrim primop [x, y]))
794 shift_code :: (Imm -> Operand -> Instr)
799 {- Case1: shift length as immediate -}
800 -- Code is the same as the first eq. for trivialCode -- sigh.
801 shift_code instr x y{-amount-}
803 = getRegister x `thenNat` \ regx ->
806 then registerCodeA regx dst `bind` \ code_x ->
808 instr imm__2 (OpReg dst)
809 else registerCodeF regx `bind` \ code_x ->
810 registerNameF regx `bind` \ r_x ->
812 MOV L (OpReg r_x) (OpReg dst) `snocOL`
813 instr imm__2 (OpReg dst)
815 returnNat (Any IntRep mkcode)
818 imm__2 = case imm of Just x -> x
820 {- Case2: shift length is complex (non-immediate) -}
821 -- Since ECX is always used as a spill temporary, we can't
822 -- use it here to do non-immediate shifts. No big deal --
823 -- they are only very rare, and we can use an equivalent
824 -- test-and-jump sequence which doesn't use ECX.
825 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
826 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
827 shift_code instr x y{-amount-}
828 = getRegister x `thenNat` \ register1 ->
829 getRegister y `thenNat` \ register2 ->
830 getNatLabelNCG `thenNat` \ lbl_test3 ->
831 getNatLabelNCG `thenNat` \ lbl_test2 ->
832 getNatLabelNCG `thenNat` \ lbl_test1 ->
833 getNatLabelNCG `thenNat` \ lbl_test0 ->
834 getNatLabelNCG `thenNat` \ lbl_after ->
835 getNewRegNCG IntRep `thenNat` \ tmp ->
837 = let src_val = registerName register1 dst
838 code_val = registerCode register1 dst
839 src_amt = registerName register2 tmp
840 code_amt = registerCode register2 tmp
845 MOV L (OpReg src_amt) r_tmp `appOL`
847 MOV L (OpReg src_val) r_dst `appOL`
849 COMMENT (_PK_ "begin shift sequence"),
850 MOV L (OpReg src_val) r_dst,
851 MOV L (OpReg src_amt) r_tmp,
853 BT L (ImmInt 4) r_tmp,
855 instr (ImmInt 16) r_dst,
858 BT L (ImmInt 3) r_tmp,
860 instr (ImmInt 8) r_dst,
863 BT L (ImmInt 2) r_tmp,
865 instr (ImmInt 4) r_dst,
868 BT L (ImmInt 1) r_tmp,
870 instr (ImmInt 2) r_dst,
873 BT L (ImmInt 0) r_tmp,
875 instr (ImmInt 1) r_dst,
878 COMMENT (_PK_ "end shift sequence")
881 returnNat (Any IntRep code__2)
884 add_code :: Size -> StixTree -> StixTree -> NatM Register
886 add_code sz x (StInt y)
887 = getRegister x `thenNat` \ register ->
888 getNewRegNCG IntRep `thenNat` \ tmp ->
890 code = registerCode register tmp
891 src1 = registerName register tmp
892 src2 = ImmInt (fromInteger y)
895 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
898 returnNat (Any IntRep code__2)
900 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
903 sub_code :: Size -> StixTree -> StixTree -> NatM Register
905 sub_code sz x (StInt y)
906 = getRegister x `thenNat` \ register ->
907 getNewRegNCG IntRep `thenNat` \ tmp ->
909 code = registerCode register tmp
910 src1 = registerName register tmp
911 src2 = ImmInt (-(fromInteger y))
914 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
917 returnNat (Any IntRep code__2)
919 sub_code sz x y = trivialCode (SUB sz) Nothing x y
922 getRegister (StInd pk mem)
923 = getAmode mem `thenNat` \ amode ->
925 code = amodeCode amode
926 src = amodeAddr amode
927 size = primRepToSize pk
928 code__2 dst = code `snocOL`
929 if pk == DoubleRep || pk == FloatRep
930 then GLD size src dst
938 (OpAddr src) (OpReg dst)
940 returnNat (Any pk code__2)
942 getRegister (StInt i)
944 src = ImmInt (fromInteger i)
947 = unitOL (XOR L (OpReg dst) (OpReg dst))
949 = unitOL (MOV L (OpImm src) (OpReg dst))
951 returnNat (Any IntRep code)
955 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
957 returnNat (Any PtrRep code)
959 = pprPanic "getRegister(x86)" (pprStixTree leaf)
962 imm__2 = case imm of Just x -> x
964 #endif {- i386_TARGET_ARCH -}
965 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
966 #if sparc_TARGET_ARCH
968 getRegister (StFloat d)
969 = getNatLabelNCG `thenNat` \ lbl ->
970 getNewRegNCG PtrRep `thenNat` \ tmp ->
971 let code dst = toOL [
976 SETHI (HI (ImmCLbl lbl)) tmp,
977 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
979 returnNat (Any FloatRep code)
981 getRegister (StDouble d)
982 = getNatLabelNCG `thenNat` \ lbl ->
983 getNewRegNCG PtrRep `thenNat` \ tmp ->
984 let code dst = toOL [
987 DATA DF [ImmDouble d],
989 SETHI (HI (ImmCLbl lbl)) tmp,
990 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
992 returnNat (Any DoubleRep code)
994 -- The 6-word scratch area is immediately below the frame pointer.
995 -- Below that is the spill area.
996 getRegister (StScratchWord i)
999 code dst = unitOL (fpRelEA (i-6) dst)
1001 returnNat (Any PtrRep code)
1004 getRegister (StPrim primop [x]) -- unary PrimOps
1006 IntNegOp -> trivialUCode (SUB False False g0) x
1007 NotOp -> trivialUCode (XNOR False g0) x
1009 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
1010 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
1012 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
1013 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
1015 OrdOp -> coerceIntCode IntRep x
1018 Float2IntOp -> coerceFP2Int x
1019 Int2FloatOp -> coerceInt2FP FloatRep x
1020 Double2IntOp -> coerceFP2Int x
1021 Int2DoubleOp -> coerceInt2FP DoubleRep x
1025 fixed_x = if is_float_op -- promote to double
1026 then StPrim Float2DoubleOp [x]
1029 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1033 FloatExpOp -> (True, SLIT("exp"))
1034 FloatLogOp -> (True, SLIT("log"))
1035 FloatSqrtOp -> (True, SLIT("sqrt"))
1037 FloatSinOp -> (True, SLIT("sin"))
1038 FloatCosOp -> (True, SLIT("cos"))
1039 FloatTanOp -> (True, SLIT("tan"))
1041 FloatAsinOp -> (True, SLIT("asin"))
1042 FloatAcosOp -> (True, SLIT("acos"))
1043 FloatAtanOp -> (True, SLIT("atan"))
1045 FloatSinhOp -> (True, SLIT("sinh"))
1046 FloatCoshOp -> (True, SLIT("cosh"))
1047 FloatTanhOp -> (True, SLIT("tanh"))
1049 DoubleExpOp -> (False, SLIT("exp"))
1050 DoubleLogOp -> (False, SLIT("log"))
1051 DoubleSqrtOp -> (False, SLIT("sqrt"))
1053 DoubleSinOp -> (False, SLIT("sin"))
1054 DoubleCosOp -> (False, SLIT("cos"))
1055 DoubleTanOp -> (False, SLIT("tan"))
1057 DoubleAsinOp -> (False, SLIT("asin"))
1058 DoubleAcosOp -> (False, SLIT("acos"))
1059 DoubleAtanOp -> (False, SLIT("atan"))
1061 DoubleSinhOp -> (False, SLIT("sinh"))
1062 DoubleCoshOp -> (False, SLIT("cosh"))
1063 DoubleTanhOp -> (False, SLIT("tanh"))
1066 -> pprPanic "getRegister(sparc,monadicprimop)"
1067 (pprStixTree (StPrim primop [x]))
1069 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1071 CharGtOp -> condIntReg GTT x y
1072 CharGeOp -> condIntReg GE x y
1073 CharEqOp -> condIntReg EQQ x y
1074 CharNeOp -> condIntReg NE x y
1075 CharLtOp -> condIntReg LTT x y
1076 CharLeOp -> condIntReg LE x y
1078 IntGtOp -> condIntReg GTT x y
1079 IntGeOp -> condIntReg GE x y
1080 IntEqOp -> condIntReg EQQ x y
1081 IntNeOp -> condIntReg NE x y
1082 IntLtOp -> condIntReg LTT x y
1083 IntLeOp -> condIntReg LE x y
1085 WordGtOp -> condIntReg GU x y
1086 WordGeOp -> condIntReg GEU x y
1087 WordEqOp -> condIntReg EQQ x y
1088 WordNeOp -> condIntReg NE x y
1089 WordLtOp -> condIntReg LU x y
1090 WordLeOp -> condIntReg LEU x y
1092 AddrGtOp -> condIntReg GU x y
1093 AddrGeOp -> condIntReg GEU x y
1094 AddrEqOp -> condIntReg EQQ x y
1095 AddrNeOp -> condIntReg NE x y
1096 AddrLtOp -> condIntReg LU x y
1097 AddrLeOp -> condIntReg LEU x y
1099 FloatGtOp -> condFltReg GTT x y
1100 FloatGeOp -> condFltReg GE x y
1101 FloatEqOp -> condFltReg EQQ x y
1102 FloatNeOp -> condFltReg NE x y
1103 FloatLtOp -> condFltReg LTT x y
1104 FloatLeOp -> condFltReg LE x y
1106 DoubleGtOp -> condFltReg GTT x y
1107 DoubleGeOp -> condFltReg GE x y
1108 DoubleEqOp -> condFltReg EQQ x y
1109 DoubleNeOp -> condFltReg NE x y
1110 DoubleLtOp -> condFltReg LTT x y
1111 DoubleLeOp -> condFltReg LE x y
1113 IntAddOp -> trivialCode (ADD False False) x y
1114 IntSubOp -> trivialCode (SUB False False) x y
1116 -- ToDo: teach about V8+ SPARC mul/div instructions
1117 IntMulOp -> imul_div SLIT(".umul") x y
1118 IntQuotOp -> imul_div SLIT(".div") x y
1119 IntRemOp -> imul_div SLIT(".rem") x y
1121 WordAddOp -> trivialCode (ADD False False) x y
1122 WordSubOp -> trivialCode (SUB False False) x y
1123 WordMulOp -> imul_div SLIT(".umul") x y
1125 FloatAddOp -> trivialFCode FloatRep FADD x y
1126 FloatSubOp -> trivialFCode FloatRep FSUB x y
1127 FloatMulOp -> trivialFCode FloatRep FMUL x y
1128 FloatDivOp -> trivialFCode FloatRep FDIV x y
1130 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1131 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1132 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1133 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1135 AndOp -> trivialCode (AND False) x y
1136 OrOp -> trivialCode (OR False) x y
1137 XorOp -> trivialCode (XOR False) x y
1138 SllOp -> trivialCode SLL x y
1139 SrlOp -> trivialCode SRL x y
1141 ISllOp -> trivialCode SLL x y
1142 ISraOp -> trivialCode SRA x y
1143 ISrlOp -> trivialCode SRL x y
1145 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1146 [promote x, promote y])
1147 where promote x = StPrim Float2DoubleOp [x]
1148 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1152 -> pprPanic "getRegister(sparc,dyadic primop)"
1153 (pprStixTree (StPrim primop [x, y]))
1156 imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1158 getRegister (StInd pk mem)
1159 = getAmode mem `thenNat` \ amode ->
1161 code = amodeCode amode
1162 src = amodeAddr amode
1163 size = primRepToSize pk
1164 code__2 dst = code `snocOL` LD size src dst
1166 returnNat (Any pk code__2)
1168 getRegister (StInt i)
1171 src = ImmInt (fromInteger i)
1172 code dst = unitOL (OR False g0 (RIImm src) dst)
1174 returnNat (Any IntRep code)
1180 SETHI (HI imm__2) dst,
1181 OR False dst (RIImm (LO imm__2)) dst]
1183 returnNat (Any PtrRep code)
1185 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1188 imm__2 = case imm of Just x -> x
1190 #endif {- sparc_TARGET_ARCH -}
1193 %************************************************************************
1195 \subsection{The @Amode@ type}
1197 %************************************************************************
1199 @Amode@s: Memory addressing modes passed up the tree.
1201 data Amode = Amode MachRegsAddr InstrBlock
1203 amodeAddr (Amode addr _) = addr
1204 amodeCode (Amode _ code) = code
1207 Now, given a tree (the argument to an StInd) that references memory,
1208 produce a suitable addressing mode.
1210 A Rule of the Game (tm) for Amodes: use of the addr bit must
1211 immediately follow use of the code part, since the code part puts
1212 values in registers which the addr then refers to. So you can't put
1213 anything in between, lest it overwrite some of those registers. If
1214 you need to do some other computation between the code part and use of
1215 the addr bit, first store the effective address from the amode in a
1216 temporary, then do the other computation, and then use the temporary:
1220 ... other computation ...
1224 getAmode :: StixTree -> NatM Amode
1226 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1228 #if alpha_TARGET_ARCH
1230 getAmode (StPrim IntSubOp [x, StInt i])
1231 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1232 getRegister x `thenNat` \ register ->
1234 code = registerCode register tmp
1235 reg = registerName register tmp
1236 off = ImmInt (-(fromInteger i))
1238 returnNat (Amode (AddrRegImm reg off) code)
1240 getAmode (StPrim IntAddOp [x, StInt i])
1241 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1242 getRegister x `thenNat` \ register ->
1244 code = registerCode register tmp
1245 reg = registerName register tmp
1246 off = ImmInt (fromInteger i)
1248 returnNat (Amode (AddrRegImm reg off) code)
1252 = returnNat (Amode (AddrImm imm__2) id)
1255 imm__2 = case imm of Just x -> x
1258 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1259 getRegister other `thenNat` \ register ->
1261 code = registerCode register tmp
1262 reg = registerName register tmp
1264 returnNat (Amode (AddrReg reg) code)
1266 #endif {- alpha_TARGET_ARCH -}
1267 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1268 #if i386_TARGET_ARCH
1270 getAmode (StPrim IntSubOp [x, StInt i])
1271 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1272 getRegister x `thenNat` \ register ->
1274 code = registerCode register tmp
1275 reg = registerName register tmp
1276 off = ImmInt (-(fromInteger i))
1278 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1280 getAmode (StPrim IntAddOp [x, StInt i])
1282 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1285 imm__2 = case imm of Just x -> x
1287 getAmode (StPrim IntAddOp [x, StInt i])
1288 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1289 getRegister x `thenNat` \ register ->
1291 code = registerCode register tmp
1292 reg = registerName register tmp
1293 off = ImmInt (fromInteger i)
1295 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1297 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1298 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1299 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1300 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1301 getRegister x `thenNat` \ register1 ->
1302 getRegister y `thenNat` \ register2 ->
1304 code1 = registerCode register1 tmp1
1305 reg1 = registerName register1 tmp1
1306 code2 = registerCode register2 tmp2
1307 reg2 = registerName register2 tmp2
1308 code__2 = code1 `appOL` code2
1309 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1311 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1316 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1319 imm__2 = case imm of Just x -> x
1322 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1323 getRegister other `thenNat` \ register ->
1325 code = registerCode register tmp
1326 reg = registerName register tmp
1328 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1330 #endif {- i386_TARGET_ARCH -}
1331 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1332 #if sparc_TARGET_ARCH
1334 getAmode (StPrim IntSubOp [x, StInt i])
1336 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1337 getRegister x `thenNat` \ register ->
1339 code = registerCode register tmp
1340 reg = registerName register tmp
1341 off = ImmInt (-(fromInteger i))
1343 returnNat (Amode (AddrRegImm reg off) code)
1346 getAmode (StPrim IntAddOp [x, StInt i])
1348 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1349 getRegister x `thenNat` \ register ->
1351 code = registerCode register tmp
1352 reg = registerName register tmp
1353 off = ImmInt (fromInteger i)
1355 returnNat (Amode (AddrRegImm reg off) code)
1357 getAmode (StPrim IntAddOp [x, y])
1358 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1359 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1360 getRegister x `thenNat` \ register1 ->
1361 getRegister y `thenNat` \ register2 ->
1363 code1 = registerCode register1 tmp1
1364 reg1 = registerName register1 tmp1
1365 code2 = registerCode register2 tmp2
1366 reg2 = registerName register2 tmp2
1367 code__2 = code1 `appOL` code2
1369 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1373 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1375 code = unitOL (SETHI (HI imm__2) tmp)
1377 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1380 imm__2 = case imm of Just x -> x
1383 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1384 getRegister other `thenNat` \ register ->
1386 code = registerCode register tmp
1387 reg = registerName register tmp
1390 returnNat (Amode (AddrRegImm reg off) code)
1392 #endif {- sparc_TARGET_ARCH -}
1395 %************************************************************************
1397 \subsection{The @CondCode@ type}
1399 %************************************************************************
1401 Condition codes passed up the tree.
1403 data CondCode = CondCode Bool Cond InstrBlock
1405 condName (CondCode _ cond _) = cond
1406 condFloat (CondCode is_float _ _) = is_float
1407 condCode (CondCode _ _ code) = code
1410 Set up a condition code for a conditional branch.
1413 getCondCode :: StixTree -> NatM CondCode
1415 #if alpha_TARGET_ARCH
1416 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1417 #endif {- alpha_TARGET_ARCH -}
1418 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1420 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1421 -- yes, they really do seem to want exactly the same!
1423 getCondCode (StPrim primop [x, y])
1425 CharGtOp -> condIntCode GTT x y
1426 CharGeOp -> condIntCode GE x y
1427 CharEqOp -> condIntCode EQQ x y
1428 CharNeOp -> condIntCode NE x y
1429 CharLtOp -> condIntCode LTT x y
1430 CharLeOp -> condIntCode LE x y
1432 IntGtOp -> condIntCode GTT x y
1433 IntGeOp -> condIntCode GE x y
1434 IntEqOp -> condIntCode EQQ x y
1435 IntNeOp -> condIntCode NE x y
1436 IntLtOp -> condIntCode LTT x y
1437 IntLeOp -> condIntCode LE x y
1439 WordGtOp -> condIntCode GU x y
1440 WordGeOp -> condIntCode GEU x y
1441 WordEqOp -> condIntCode EQQ x y
1442 WordNeOp -> condIntCode NE x y
1443 WordLtOp -> condIntCode LU x y
1444 WordLeOp -> condIntCode LEU x y
1446 AddrGtOp -> condIntCode GU x y
1447 AddrGeOp -> condIntCode GEU x y
1448 AddrEqOp -> condIntCode EQQ x y
1449 AddrNeOp -> condIntCode NE x y
1450 AddrLtOp -> condIntCode LU x y
1451 AddrLeOp -> condIntCode LEU x y
1453 FloatGtOp -> condFltCode GTT x y
1454 FloatGeOp -> condFltCode GE x y
1455 FloatEqOp -> condFltCode EQQ x y
1456 FloatNeOp -> condFltCode NE x y
1457 FloatLtOp -> condFltCode LTT x y
1458 FloatLeOp -> condFltCode LE x y
1460 DoubleGtOp -> condFltCode GTT x y
1461 DoubleGeOp -> condFltCode GE x y
1462 DoubleEqOp -> condFltCode EQQ x y
1463 DoubleNeOp -> condFltCode NE x y
1464 DoubleLtOp -> condFltCode LTT x y
1465 DoubleLeOp -> condFltCode LE x y
1467 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1472 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1473 passed back up the tree.
1476 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1478 #if alpha_TARGET_ARCH
1479 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1480 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1481 #endif {- alpha_TARGET_ARCH -}
1483 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1484 #if i386_TARGET_ARCH
1486 -- memory vs immediate
1487 condIntCode cond (StInd pk x) y
1489 = getAmode x `thenNat` \ amode ->
1491 code1 = amodeCode amode
1492 x__2 = amodeAddr amode
1493 sz = primRepToSize pk
1494 code__2 = code1 `snocOL`
1495 CMP sz (OpImm imm__2) (OpAddr x__2)
1497 returnNat (CondCode False cond code__2)
1500 imm__2 = case imm of Just x -> x
1503 condIntCode cond x (StInt 0)
1504 = getRegister x `thenNat` \ register1 ->
1505 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1507 code1 = registerCode register1 tmp1
1508 src1 = registerName register1 tmp1
1509 code__2 = code1 `snocOL`
1510 TEST L (OpReg src1) (OpReg src1)
1512 returnNat (CondCode False cond code__2)
1514 -- anything vs immediate
1515 condIntCode cond x y
1517 = getRegister x `thenNat` \ register1 ->
1518 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1520 code1 = registerCode register1 tmp1
1521 src1 = registerName register1 tmp1
1522 code__2 = code1 `snocOL`
1523 CMP L (OpImm imm__2) (OpReg src1)
1525 returnNat (CondCode False cond code__2)
1528 imm__2 = case imm of Just x -> x
1530 -- memory vs anything
1531 condIntCode cond (StInd pk x) y
1532 = getAmode x `thenNat` \ amode_x ->
1533 getRegister y `thenNat` \ reg_y ->
1534 getNewRegNCG IntRep `thenNat` \ tmp ->
1536 c_x = amodeCode amode_x
1537 am_x = amodeAddr amode_x
1538 c_y = registerCode reg_y tmp
1539 r_y = registerName reg_y tmp
1540 sz = primRepToSize pk
1542 -- optimisation: if there's no code for x, just an amode,
1543 -- use whatever reg y winds up in. Assumes that c_y doesn't
1544 -- clobber any regs in the amode am_x, which I'm not sure is
1545 -- justified. The otherwise clause makes the same assumption.
1546 code__2 | isNilOL c_x
1548 CMP sz (OpReg r_y) (OpAddr am_x)
1552 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1554 CMP sz (OpReg tmp) (OpAddr am_x)
1556 returnNat (CondCode False cond code__2)
1558 -- anything vs memory
1560 condIntCode cond y (StInd pk x)
1561 = getAmode x `thenNat` \ amode_x ->
1562 getRegister y `thenNat` \ reg_y ->
1563 getNewRegNCG IntRep `thenNat` \ tmp ->
1565 c_x = amodeCode amode_x
1566 am_x = amodeAddr amode_x
1567 c_y = registerCode reg_y tmp
1568 r_y = registerName reg_y tmp
1569 sz = primRepToSize pk
1570 -- same optimisation and nagging doubts as previous clause
1571 code__2 | isNilOL c_x
1573 CMP sz (OpAddr am_x) (OpReg r_y)
1577 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1579 CMP sz (OpAddr am_x) (OpReg tmp)
1581 returnNat (CondCode False cond code__2)
1583 -- anything vs anything
1584 condIntCode cond x y
1585 = getRegister x `thenNat` \ register1 ->
1586 getRegister y `thenNat` \ register2 ->
1587 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1588 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1590 code1 = registerCode register1 tmp1
1591 src1 = registerName register1 tmp1
1592 code2 = registerCode register2 tmp2
1593 src2 = registerName register2 tmp2
1594 code__2 = code1 `snocOL`
1595 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1597 CMP L (OpReg src2) (OpReg tmp1)
1599 returnNat (CondCode False cond code__2)
1602 condFltCode cond x y
1603 = getRegister x `thenNat` \ register1 ->
1604 getRegister y `thenNat` \ register2 ->
1605 getNewRegNCG (registerRep register1)
1607 getNewRegNCG (registerRep register2)
1609 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1611 pk1 = registerRep register1
1612 code1 = registerCode register1 tmp1
1613 src1 = registerName register1 tmp1
1615 code2 = registerCode register2 tmp2
1616 src2 = registerName register2 tmp2
1618 code__2 | isAny register1
1619 = code1 `appOL` -- result in tmp1
1621 GCMP (primRepToSize pk1) tmp1 src2
1625 GMOV src1 tmp1 `appOL`
1627 GCMP (primRepToSize pk1) tmp1 src2
1629 {- On the 486, the flags set by FP compare are the unsigned ones!
1630 (This looks like a HACK to me. WDP 96/03)
1632 fix_FP_cond :: Cond -> Cond
1634 fix_FP_cond GE = GEU
1635 fix_FP_cond GTT = GU
1636 fix_FP_cond LTT = LU
1637 fix_FP_cond LE = LEU
1638 fix_FP_cond any = any
1640 returnNat (CondCode True (fix_FP_cond cond) code__2)
1644 #endif {- i386_TARGET_ARCH -}
1645 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1646 #if sparc_TARGET_ARCH
1648 condIntCode cond x (StInt y)
1650 = getRegister x `thenNat` \ register ->
1651 getNewRegNCG IntRep `thenNat` \ tmp ->
1653 code = registerCode register tmp
1654 src1 = registerName register tmp
1655 src2 = ImmInt (fromInteger y)
1656 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1658 returnNat (CondCode False cond code__2)
1660 condIntCode cond x y
1661 = getRegister x `thenNat` \ register1 ->
1662 getRegister y `thenNat` \ register2 ->
1663 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1664 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1666 code1 = registerCode register1 tmp1
1667 src1 = registerName register1 tmp1
1668 code2 = registerCode register2 tmp2
1669 src2 = registerName register2 tmp2
1670 code__2 = code1 `appOL` code2 `snocOL`
1671 SUB False True src1 (RIReg src2) g0
1673 returnNat (CondCode False cond code__2)
1676 condFltCode cond x y
1677 = getRegister x `thenNat` \ register1 ->
1678 getRegister y `thenNat` \ register2 ->
1679 getNewRegNCG (registerRep register1)
1681 getNewRegNCG (registerRep register2)
1683 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1685 promote x = FxTOy F DF x tmp
1687 pk1 = registerRep register1
1688 code1 = registerCode register1 tmp1
1689 src1 = registerName register1 tmp1
1691 pk2 = registerRep register2
1692 code2 = registerCode register2 tmp2
1693 src2 = registerName register2 tmp2
1697 code1 `appOL` code2 `snocOL`
1698 FCMP True (primRepToSize pk1) src1 src2
1699 else if pk1 == FloatRep then
1700 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1701 FCMP True DF tmp src2
1703 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1704 FCMP True DF src1 tmp
1706 returnNat (CondCode True cond code__2)
1708 #endif {- sparc_TARGET_ARCH -}
1711 %************************************************************************
1713 \subsection{Generating assignments}
1715 %************************************************************************
1717 Assignments are really at the heart of the whole code generation
1718 business. Almost all top-level nodes of any real importance are
1719 assignments, which correspond to loads, stores, or register transfers.
1720 If we're really lucky, some of the register transfers will go away,
1721 because we can use the destination register to complete the code
1722 generation for the right hand side. This only fails when the right
1723 hand side is forced into a fixed register (e.g. the result of a call).
1726 assignIntCode, assignFltCode
1727 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1729 #if alpha_TARGET_ARCH
1731 assignIntCode pk (StInd _ dst) src
1732 = getNewRegNCG IntRep `thenNat` \ tmp ->
1733 getAmode dst `thenNat` \ amode ->
1734 getRegister src `thenNat` \ register ->
1736 code1 = amodeCode amode []
1737 dst__2 = amodeAddr amode
1738 code2 = registerCode register tmp []
1739 src__2 = registerName register tmp
1740 sz = primRepToSize pk
1741 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1745 assignIntCode pk dst src
1746 = getRegister dst `thenNat` \ register1 ->
1747 getRegister src `thenNat` \ register2 ->
1749 dst__2 = registerName register1 zeroh
1750 code = registerCode register2 dst__2
1751 src__2 = registerName register2 dst__2
1752 code__2 = if isFixed register2
1753 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1758 #endif {- alpha_TARGET_ARCH -}
1759 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1760 #if i386_TARGET_ARCH
1762 -- Destination of an assignment can only be reg or mem.
1763 -- This is the mem case.
1764 assignIntCode pk (StInd _ dst) src
1765 = getAmode dst `thenNat` \ amode ->
1766 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1767 getNewRegNCG PtrRep `thenNat` \ tmp ->
1769 -- In general, if the address computation for dst may require
1770 -- some insns preceding the addressing mode itself. So there's
1771 -- no guarantee that the code for dst and the code for src won't
1772 -- write the same register. This means either the address or
1773 -- the value needs to be copied into a temporary. We detect the
1774 -- common case where the amode has no code, and elide the copy.
1775 codea = amodeCode amode
1776 dst__a = amodeAddr amode
1778 code | isNilOL codea
1780 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1784 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1786 MOV (primRepToSize pk) opsrc
1787 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1793 -> NatM (InstrBlock,Operand) -- code, operator
1797 = returnNat (nilOL, OpImm imm_op)
1800 imm_op = case imm of Just x -> x
1803 = getRegister op `thenNat` \ register ->
1804 getNewRegNCG (registerRep register)
1806 let code = registerCode register tmp
1807 reg = registerName register tmp
1809 returnNat (code, OpReg reg)
1811 -- Assign; dst is a reg, rhs is mem
1812 assignIntCode pk dst (StInd pks src)
1813 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1814 getAmode src `thenNat` \ amode ->
1815 getRegister dst `thenNat` \ reg_dst ->
1817 c_addr = amodeCode amode
1818 am_addr = amodeAddr amode
1820 c_dst = registerCode reg_dst tmp -- should be empty
1821 r_dst = registerName reg_dst tmp
1822 szs = primRepToSize pks
1831 code | isNilOL c_dst
1833 opc (OpAddr am_addr) (OpReg r_dst)
1835 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1839 -- dst is a reg, but src could be anything
1840 assignIntCode pk dst src
1841 = getRegister dst `thenNat` \ registerd ->
1842 getRegister src `thenNat` \ registers ->
1843 getNewRegNCG IntRep `thenNat` \ tmp ->
1845 r_dst = registerName registerd tmp
1846 c_dst = registerCode registerd tmp -- should be empty
1847 r_src = registerName registers r_dst
1848 c_src = registerCode registers r_dst
1850 code | isNilOL c_dst
1852 MOV L (OpReg r_src) (OpReg r_dst)
1854 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1858 #endif {- i386_TARGET_ARCH -}
1859 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1860 #if sparc_TARGET_ARCH
1862 assignIntCode pk (StInd _ dst) src
1863 = getNewRegNCG IntRep `thenNat` \ tmp ->
1864 getAmode dst `thenNat` \ amode ->
1865 getRegister src `thenNat` \ register ->
1867 code1 = amodeCode amode
1868 dst__2 = amodeAddr amode
1869 code2 = registerCode register tmp
1870 src__2 = registerName register tmp
1871 sz = primRepToSize pk
1872 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1876 assignIntCode pk dst src
1877 = getRegister dst `thenNat` \ register1 ->
1878 getRegister src `thenNat` \ register2 ->
1880 dst__2 = registerName register1 g0
1881 code = registerCode register2 dst__2
1882 src__2 = registerName register2 dst__2
1883 code__2 = if isFixed register2
1884 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1889 #endif {- sparc_TARGET_ARCH -}
1892 % --------------------------------
1893 Floating-point assignments:
1894 % --------------------------------
1896 #if alpha_TARGET_ARCH
1898 assignFltCode pk (StInd _ dst) src
1899 = getNewRegNCG pk `thenNat` \ tmp ->
1900 getAmode dst `thenNat` \ amode ->
1901 getRegister src `thenNat` \ register ->
1903 code1 = amodeCode amode []
1904 dst__2 = amodeAddr amode
1905 code2 = registerCode register tmp []
1906 src__2 = registerName register tmp
1907 sz = primRepToSize pk
1908 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1912 assignFltCode pk dst src
1913 = getRegister dst `thenNat` \ register1 ->
1914 getRegister src `thenNat` \ register2 ->
1916 dst__2 = registerName register1 zeroh
1917 code = registerCode register2 dst__2
1918 src__2 = registerName register2 dst__2
1919 code__2 = if isFixed register2
1920 then code . mkSeqInstr (FMOV src__2 dst__2)
1925 #endif {- alpha_TARGET_ARCH -}
1926 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1927 #if i386_TARGET_ARCH
1930 assignFltCode pk (StInd pk_dst addr) src
1932 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1934 = getRegister src `thenNat` \ reg_src ->
1935 getRegister addr `thenNat` \ reg_addr ->
1936 getNewRegNCG pk `thenNat` \ tmp_src ->
1937 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1938 let r_src = registerName reg_src tmp_src
1939 c_src = registerCode reg_src tmp_src
1940 r_addr = registerName reg_addr tmp_addr
1941 c_addr = registerCode reg_addr tmp_addr
1942 sz = primRepToSize pk
1944 code = c_src `appOL`
1945 -- no need to preserve r_src across the addr computation,
1946 -- since r_src must be a float reg
1947 -- whilst r_addr is an int reg
1950 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1954 -- dst must be a (FP) register
1955 assignFltCode pk dst src
1956 = getRegister dst `thenNat` \ reg_dst ->
1957 getRegister src `thenNat` \ reg_src ->
1958 getNewRegNCG pk `thenNat` \ tmp ->
1960 r_dst = registerName reg_dst tmp
1961 c_dst = registerCode reg_dst tmp -- should be empty
1963 r_src = registerName reg_src r_dst
1964 c_src = registerCode reg_src r_dst
1966 code | isNilOL c_dst
1967 = if isFixed reg_src
1968 then c_src `snocOL` GMOV r_src r_dst
1971 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1977 #endif {- i386_TARGET_ARCH -}
1978 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1979 #if sparc_TARGET_ARCH
1981 assignFltCode pk (StInd _ dst) src
1982 = getNewRegNCG pk `thenNat` \ tmp1 ->
1983 getAmode dst `thenNat` \ amode ->
1984 getRegister src `thenNat` \ register ->
1986 sz = primRepToSize pk
1987 dst__2 = amodeAddr amode
1989 code1 = amodeCode amode
1990 code2 = registerCode register tmp1
1992 src__2 = registerName register tmp1
1993 pk__2 = registerRep register
1994 sz__2 = primRepToSize pk__2
1996 code__2 = code1 `appOL` code2 `appOL`
1998 then unitOL (ST sz src__2 dst__2)
1999 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2003 assignFltCode pk dst src
2004 = getRegister dst `thenNat` \ register1 ->
2005 getRegister src `thenNat` \ register2 ->
2007 pk__2 = registerRep register2
2008 sz__2 = primRepToSize pk__2
2010 getNewRegNCG pk__2 `thenNat` \ tmp ->
2012 sz = primRepToSize pk
2013 dst__2 = registerName register1 g0 -- must be Fixed
2016 reg__2 = if pk /= pk__2 then tmp else dst__2
2018 code = registerCode register2 reg__2
2020 src__2 = registerName register2 reg__2
2024 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2025 else if isFixed register2 then
2026 code `snocOL` FMOV sz src__2 dst__2
2032 #endif {- sparc_TARGET_ARCH -}
2035 %************************************************************************
2037 \subsection{Generating an unconditional branch}
2039 %************************************************************************
2041 We accept two types of targets: an immediate CLabel or a tree that
2042 gets evaluated into a register. Any CLabels which are AsmTemporaries
2043 are assumed to be in the local block of code, close enough for a
2044 branch instruction. Other CLabels are assumed to be far away.
2046 (If applicable) Do not fill the delay slots here; you will confuse the
2050 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
2052 #if alpha_TARGET_ARCH
2054 genJump (StCLbl lbl)
2055 | isAsmTemp lbl = returnInstr (BR target)
2056 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2058 target = ImmCLbl lbl
2061 = getRegister tree `thenNat` \ register ->
2062 getNewRegNCG PtrRep `thenNat` \ tmp ->
2064 dst = registerName register pv
2065 code = registerCode register pv
2066 target = registerName register pv
2068 if isFixed register then
2069 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2071 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2073 #endif {- alpha_TARGET_ARCH -}
2074 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2075 #if i386_TARGET_ARCH
2077 genJump dsts (StInd pk mem)
2078 = getAmode mem `thenNat` \ amode ->
2080 code = amodeCode amode
2081 target = amodeAddr amode
2083 returnNat (code `snocOL` JMP dsts (OpAddr target))
2087 = returnNat (unitOL (JMP dsts (OpImm target)))
2090 = getRegister tree `thenNat` \ register ->
2091 getNewRegNCG PtrRep `thenNat` \ tmp ->
2093 code = registerCode register tmp
2094 target = registerName register tmp
2096 returnNat (code `snocOL` JMP dsts (OpReg target))
2099 target = case imm of Just x -> x
2101 #endif {- i386_TARGET_ARCH -}
2102 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2103 #if sparc_TARGET_ARCH
2105 genJump dsts (StCLbl lbl)
2106 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2107 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2108 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2110 target = ImmCLbl lbl
2113 = getRegister tree `thenNat` \ register ->
2114 getNewRegNCG PtrRep `thenNat` \ tmp ->
2116 code = registerCode register tmp
2117 target = registerName register tmp
2119 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2121 #endif {- sparc_TARGET_ARCH -}
2124 %************************************************************************
2126 \subsection{Conditional jumps}
2128 %************************************************************************
2130 Conditional jumps are always to local labels, so we can use branch
2131 instructions. We peek at the arguments to decide what kind of
2134 ALPHA: For comparisons with 0, we're laughing, because we can just do
2135 the desired conditional branch.
2137 I386: First, we have to ensure that the condition
2138 codes are set according to the supplied comparison operation.
2140 SPARC: First, we have to ensure that the condition codes are set
2141 according to the supplied comparison operation. We generate slightly
2142 different code for floating point comparisons, because a floating
2143 point operation cannot directly precede a @BF@. We assume the worst
2144 and fill that slot with a @NOP@.
2146 SPARC: Do not fill the delay slots here; you will confuse the register
2151 :: CLabel -- the branch target
2152 -> StixTree -- the condition on which to branch
2155 #if alpha_TARGET_ARCH
2157 genCondJump lbl (StPrim op [x, StInt 0])
2158 = getRegister x `thenNat` \ register ->
2159 getNewRegNCG (registerRep register)
2162 code = registerCode register tmp
2163 value = registerName register tmp
2164 pk = registerRep register
2165 target = ImmCLbl lbl
2167 returnSeq code [BI (cmpOp op) value target]
2169 cmpOp CharGtOp = GTT
2171 cmpOp CharEqOp = EQQ
2173 cmpOp CharLtOp = LTT
2182 cmpOp WordGeOp = ALWAYS
2183 cmpOp WordEqOp = EQQ
2185 cmpOp WordLtOp = NEVER
2186 cmpOp WordLeOp = EQQ
2188 cmpOp AddrGeOp = ALWAYS
2189 cmpOp AddrEqOp = EQQ
2191 cmpOp AddrLtOp = NEVER
2192 cmpOp AddrLeOp = EQQ
2194 genCondJump lbl (StPrim op [x, StDouble 0.0])
2195 = getRegister x `thenNat` \ register ->
2196 getNewRegNCG (registerRep register)
2199 code = registerCode register tmp
2200 value = registerName register tmp
2201 pk = registerRep register
2202 target = ImmCLbl lbl
2204 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2206 cmpOp FloatGtOp = GTT
2207 cmpOp FloatGeOp = GE
2208 cmpOp FloatEqOp = EQQ
2209 cmpOp FloatNeOp = NE
2210 cmpOp FloatLtOp = LTT
2211 cmpOp FloatLeOp = LE
2212 cmpOp DoubleGtOp = GTT
2213 cmpOp DoubleGeOp = GE
2214 cmpOp DoubleEqOp = EQQ
2215 cmpOp DoubleNeOp = NE
2216 cmpOp DoubleLtOp = LTT
2217 cmpOp DoubleLeOp = LE
2219 genCondJump lbl (StPrim op [x, y])
2221 = trivialFCode pr instr x y `thenNat` \ register ->
2222 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2224 code = registerCode register tmp
2225 result = registerName register tmp
2226 target = ImmCLbl lbl
2228 returnNat (code . mkSeqInstr (BF cond result target))
2230 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2232 fltCmpOp op = case op of
2246 (instr, cond) = case op of
2247 FloatGtOp -> (FCMP TF LE, EQQ)
2248 FloatGeOp -> (FCMP TF LTT, EQQ)
2249 FloatEqOp -> (FCMP TF EQQ, NE)
2250 FloatNeOp -> (FCMP TF EQQ, EQQ)
2251 FloatLtOp -> (FCMP TF LTT, NE)
2252 FloatLeOp -> (FCMP TF LE, NE)
2253 DoubleGtOp -> (FCMP TF LE, EQQ)
2254 DoubleGeOp -> (FCMP TF LTT, EQQ)
2255 DoubleEqOp -> (FCMP TF EQQ, NE)
2256 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2257 DoubleLtOp -> (FCMP TF LTT, NE)
2258 DoubleLeOp -> (FCMP TF LE, NE)
2260 genCondJump lbl (StPrim op [x, y])
2261 = trivialCode instr x y `thenNat` \ register ->
2262 getNewRegNCG IntRep `thenNat` \ tmp ->
2264 code = registerCode register tmp
2265 result = registerName register tmp
2266 target = ImmCLbl lbl
2268 returnNat (code . mkSeqInstr (BI cond result target))
2270 (instr, cond) = case op of
2271 CharGtOp -> (CMP LE, EQQ)
2272 CharGeOp -> (CMP LTT, EQQ)
2273 CharEqOp -> (CMP EQQ, NE)
2274 CharNeOp -> (CMP EQQ, EQQ)
2275 CharLtOp -> (CMP LTT, NE)
2276 CharLeOp -> (CMP LE, NE)
2277 IntGtOp -> (CMP LE, EQQ)
2278 IntGeOp -> (CMP LTT, EQQ)
2279 IntEqOp -> (CMP EQQ, NE)
2280 IntNeOp -> (CMP EQQ, EQQ)
2281 IntLtOp -> (CMP LTT, NE)
2282 IntLeOp -> (CMP LE, NE)
2283 WordGtOp -> (CMP ULE, EQQ)
2284 WordGeOp -> (CMP ULT, EQQ)
2285 WordEqOp -> (CMP EQQ, NE)
2286 WordNeOp -> (CMP EQQ, EQQ)
2287 WordLtOp -> (CMP ULT, NE)
2288 WordLeOp -> (CMP ULE, NE)
2289 AddrGtOp -> (CMP ULE, EQQ)
2290 AddrGeOp -> (CMP ULT, EQQ)
2291 AddrEqOp -> (CMP EQQ, NE)
2292 AddrNeOp -> (CMP EQQ, EQQ)
2293 AddrLtOp -> (CMP ULT, NE)
2294 AddrLeOp -> (CMP ULE, NE)
2296 #endif {- alpha_TARGET_ARCH -}
2297 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2298 #if i386_TARGET_ARCH
2300 genCondJump lbl bool
2301 = getCondCode bool `thenNat` \ condition ->
2303 code = condCode condition
2304 cond = condName condition
2306 returnNat (code `snocOL` JXX cond lbl)
2308 #endif {- i386_TARGET_ARCH -}
2309 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2310 #if sparc_TARGET_ARCH
2312 genCondJump lbl bool
2313 = getCondCode bool `thenNat` \ condition ->
2315 code = condCode condition
2316 cond = condName condition
2317 target = ImmCLbl lbl
2322 if condFloat condition
2323 then [NOP, BF cond False target, NOP]
2324 else [BI cond False target, NOP]
2328 #endif {- sparc_TARGET_ARCH -}
2331 %************************************************************************
2333 \subsection{Generating C calls}
2335 %************************************************************************
2337 Now the biggest nightmare---calls. Most of the nastiness is buried in
2338 @get_arg@, which moves the arguments to the correct registers/stack
2339 locations. Apart from that, the code is easy.
2341 (If applicable) Do not fill the delay slots here; you will confuse the
2346 :: FAST_STRING -- function to call
2348 -> PrimRep -- type of the result
2349 -> [StixTree] -- arguments (of mixed type)
2352 #if alpha_TARGET_ARCH
2354 genCCall fn cconv kind args
2355 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2356 `thenNat` \ ((unused,_), argCode) ->
2358 nRegs = length allArgRegs - length unused
2359 code = asmSeqThen (map ($ []) argCode)
2362 LDA pv (AddrImm (ImmLab (ptext fn))),
2363 JSR ra (AddrReg pv) nRegs,
2364 LDGP gp (AddrReg ra)]
2366 ------------------------
2367 {- Try to get a value into a specific register (or registers) for
2368 a call. The first 6 arguments go into the appropriate
2369 argument register (separate registers for integer and floating
2370 point arguments, but used in lock-step), and the remaining
2371 arguments are dumped to the stack, beginning at 0(sp). Our
2372 first argument is a pair of the list of remaining argument
2373 registers to be assigned for this call and the next stack
2374 offset to use for overflowing arguments. This way,
2375 @get_Arg@ can be applied to all of a call's arguments using
2379 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2380 -> StixTree -- Current argument
2381 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2383 -- We have to use up all of our argument registers first...
2385 get_arg ((iDst,fDst):dsts, offset) arg
2386 = getRegister arg `thenNat` \ register ->
2388 reg = if isFloatingRep pk then fDst else iDst
2389 code = registerCode register reg
2390 src = registerName register reg
2391 pk = registerRep register
2394 if isFloatingRep pk then
2395 ((dsts, offset), if isFixed register then
2396 code . mkSeqInstr (FMOV src fDst)
2399 ((dsts, offset), if isFixed register then
2400 code . mkSeqInstr (OR src (RIReg src) iDst)
2403 -- Once we have run out of argument registers, we move to the
2406 get_arg ([], offset) arg
2407 = getRegister arg `thenNat` \ register ->
2408 getNewRegNCG (registerRep register)
2411 code = registerCode register tmp
2412 src = registerName register tmp
2413 pk = registerRep register
2414 sz = primRepToSize pk
2416 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2418 #endif {- alpha_TARGET_ARCH -}
2419 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2420 #if i386_TARGET_ARCH
2422 genCCall fn cconv kind [StInt i]
2423 | fn == SLIT ("PerformGC_wrapper")
2425 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2426 CALL (ImmLit (ptext (if underscorePrefix
2427 then (SLIT ("_PerformGC_wrapper"))
2428 else (SLIT ("PerformGC_wrapper")))))
2434 genCCall fn cconv kind args
2435 = mapNat get_call_arg
2436 (reverse args) `thenNat` \ sizes_n_codes ->
2437 getDeltaNat `thenNat` \ delta ->
2438 let (sizes, codes) = unzip sizes_n_codes
2439 tot_arg_size = sum sizes
2440 code2 = concatOL codes
2442 [CALL (fn__2 tot_arg_size)]
2444 (if cconv == StdCallConv then [] else
2445 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2447 [DELTA (delta + tot_arg_size)]
2450 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2451 returnNat (code2 `appOL` call)
2454 -- function names that begin with '.' are assumed to be special
2455 -- internally generated names like '.mul,' which don't get an
2456 -- underscore prefix
2457 -- ToDo:needed (WDP 96/03) ???
2461 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2463 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2465 stdcallsize tot_arg_size
2466 | cconv == StdCallConv = '@':show tot_arg_size
2474 get_call_arg :: StixTree{-current argument-}
2475 -> NatM (Int, InstrBlock) -- argsz, code
2478 = get_op arg `thenNat` \ (code, reg, sz) ->
2479 getDeltaNat `thenNat` \ delta ->
2480 arg_size sz `bind` \ size ->
2481 setDeltaNat (delta-size) `thenNat` \ _ ->
2482 if (case sz of DF -> True; F -> True; _ -> False)
2483 then returnNat (size,
2485 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2487 GST sz reg (AddrBaseIndex (Just esp)
2491 else returnNat (size,
2493 PUSH L (OpReg reg) `snocOL`
2499 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2502 = getRegister op `thenNat` \ register ->
2503 getNewRegNCG (registerRep register)
2506 code = registerCode register tmp
2507 reg = registerName register tmp
2508 pk = registerRep register
2509 sz = primRepToSize pk
2511 returnNat (code, reg, sz)
2513 #endif {- i386_TARGET_ARCH -}
2514 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2515 #if sparc_TARGET_ARCH
2517 The SPARC calling convention is an absolute
2518 nightmare. The first 6x32 bits of arguments are mapped into
2519 %o0 through %o5, and the remaining arguments are dumped to the
2520 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2522 If we have to put args on the stack, move %o6==%sp down by
2523 the number of words to go on the stack, to ensure there's enough space.
2525 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2526 16 words above the stack pointer is a word for the address of
2527 a structure return value. I use this as a temporary location
2528 for moving values from float to int regs. Certainly it isn't
2529 safe to put anything in the 16 words starting at %sp, since
2530 this area can get trashed at any time due to window overflows
2531 caused by signal handlers.
2533 A final complication (if the above isn't enough) is that
2534 we can't blithely calculate the arguments one by one into
2535 %o0 .. %o5. Consider the following nested calls:
2539 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2540 the inner call will itself use %o0, which trashes the value put there
2541 in preparation for the outer call. Upshot: we need to calculate the
2542 args into temporary regs, and move those to arg regs or onto the
2543 stack only immediately prior to the call proper. Sigh.
2546 genCCall fn cconv kind args
2547 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2548 let (argcodes, vregss) = unzip argcode_and_vregs
2549 argcode = concatOL argcodes
2550 vregs = concat vregss
2551 n_argRegs = length allArgRegs
2552 n_argRegs_used = min (length vregs) n_argRegs
2553 (move_sp_down, move_sp_up)
2554 = let nn = length vregs - n_argRegs
2555 + 1 -- (for the road)
2558 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2560 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2562 = unitOL (CALL fn__2 n_argRegs_used False)
2564 returnNat (argcode `appOL`
2565 move_sp_down `appOL`
2566 transfer_code `appOL`
2571 -- function names that begin with '.' are assumed to be special
2572 -- internally generated names like '.mul,' which don't get an
2573 -- underscore prefix
2574 -- ToDo:needed (WDP 96/03) ???
2575 fn__2 = case (_HEAD_ fn) of
2576 '.' -> ImmLit (ptext fn)
2577 _ -> ImmLab False (ptext fn)
2579 -- move args from the integer vregs into which they have been
2580 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2581 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2583 move_final [] _ offset -- all args done
2586 move_final (v:vs) [] offset -- out of aregs; move to stack
2587 = ST W v (spRel offset)
2588 : move_final vs [] (offset+1)
2590 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2591 = OR False g0 (RIReg v) a
2592 : move_final vs az offset
2594 -- generate code to calculate an argument, and move it into one
2595 -- or two integer vregs.
2596 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2597 arg_to_int_vregs arg
2598 = getRegister arg `thenNat` \ register ->
2599 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2600 let code = registerCode register tmp
2601 src = registerName register tmp
2602 pk = registerRep register
2604 -- the value is in src. Get it into 1 or 2 int vregs.
2607 getNewRegNCG WordRep `thenNat` \ v1 ->
2608 getNewRegNCG WordRep `thenNat` \ v2 ->
2611 FMOV DF src f0 `snocOL`
2612 ST F f0 (spRel 16) `snocOL`
2613 LD W (spRel 16) v1 `snocOL`
2614 ST F (fPair f0) (spRel 16) `snocOL`
2620 getNewRegNCG WordRep `thenNat` \ v1 ->
2623 ST F src (spRel 16) `snocOL`
2629 getNewRegNCG WordRep `thenNat` \ v1 ->
2631 code `snocOL` OR False g0 (RIReg src) v1
2635 #endif {- sparc_TARGET_ARCH -}
2638 %************************************************************************
2640 \subsection{Support bits}
2642 %************************************************************************
2644 %************************************************************************
2646 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2648 %************************************************************************
2650 Turn those condition codes into integers now (when they appear on
2651 the right hand side of an assignment).
2653 (If applicable) Do not fill the delay slots here; you will confuse the
2657 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2659 #if alpha_TARGET_ARCH
2660 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2661 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2662 #endif {- alpha_TARGET_ARCH -}
2664 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2665 #if i386_TARGET_ARCH
2668 = condIntCode cond x y `thenNat` \ condition ->
2669 getNewRegNCG IntRep `thenNat` \ tmp ->
2671 code = condCode condition
2672 cond = condName condition
2673 code__2 dst = code `appOL` toOL [
2674 SETCC cond (OpReg tmp),
2675 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2676 MOV L (OpReg tmp) (OpReg dst)]
2678 returnNat (Any IntRep code__2)
2681 = getNatLabelNCG `thenNat` \ lbl1 ->
2682 getNatLabelNCG `thenNat` \ lbl2 ->
2683 condFltCode cond x y `thenNat` \ condition ->
2685 code = condCode condition
2686 cond = condName condition
2687 code__2 dst = code `appOL` toOL [
2689 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2692 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2695 returnNat (Any IntRep code__2)
2697 #endif {- i386_TARGET_ARCH -}
2698 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2699 #if sparc_TARGET_ARCH
2701 condIntReg EQQ x (StInt 0)
2702 = getRegister x `thenNat` \ register ->
2703 getNewRegNCG IntRep `thenNat` \ tmp ->
2705 code = registerCode register tmp
2706 src = registerName register tmp
2707 code__2 dst = code `appOL` toOL [
2708 SUB False True g0 (RIReg src) g0,
2709 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2711 returnNat (Any IntRep code__2)
2714 = getRegister x `thenNat` \ register1 ->
2715 getRegister y `thenNat` \ register2 ->
2716 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2717 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2719 code1 = registerCode register1 tmp1
2720 src1 = registerName register1 tmp1
2721 code2 = registerCode register2 tmp2
2722 src2 = registerName register2 tmp2
2723 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2724 XOR False src1 (RIReg src2) dst,
2725 SUB False True g0 (RIReg dst) g0,
2726 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2728 returnNat (Any IntRep code__2)
2730 condIntReg NE x (StInt 0)
2731 = getRegister x `thenNat` \ register ->
2732 getNewRegNCG IntRep `thenNat` \ tmp ->
2734 code = registerCode register tmp
2735 src = registerName register tmp
2736 code__2 dst = code `appOL` toOL [
2737 SUB False True g0 (RIReg src) g0,
2738 ADD True False g0 (RIImm (ImmInt 0)) dst]
2740 returnNat (Any IntRep code__2)
2743 = getRegister x `thenNat` \ register1 ->
2744 getRegister y `thenNat` \ register2 ->
2745 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2746 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2748 code1 = registerCode register1 tmp1
2749 src1 = registerName register1 tmp1
2750 code2 = registerCode register2 tmp2
2751 src2 = registerName register2 tmp2
2752 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2753 XOR False src1 (RIReg src2) dst,
2754 SUB False True g0 (RIReg dst) g0,
2755 ADD True False g0 (RIImm (ImmInt 0)) dst]
2757 returnNat (Any IntRep code__2)
2760 = getNatLabelNCG `thenNat` \ lbl1 ->
2761 getNatLabelNCG `thenNat` \ lbl2 ->
2762 condIntCode cond x y `thenNat` \ condition ->
2764 code = condCode condition
2765 cond = condName condition
2766 code__2 dst = code `appOL` toOL [
2767 BI cond False (ImmCLbl lbl1), NOP,
2768 OR False g0 (RIImm (ImmInt 0)) dst,
2769 BI ALWAYS False (ImmCLbl lbl2), NOP,
2771 OR False g0 (RIImm (ImmInt 1)) dst,
2774 returnNat (Any IntRep code__2)
2777 = getNatLabelNCG `thenNat` \ lbl1 ->
2778 getNatLabelNCG `thenNat` \ lbl2 ->
2779 condFltCode cond x y `thenNat` \ condition ->
2781 code = condCode condition
2782 cond = condName condition
2783 code__2 dst = code `appOL` toOL [
2785 BF cond False (ImmCLbl lbl1), NOP,
2786 OR False g0 (RIImm (ImmInt 0)) dst,
2787 BI ALWAYS False (ImmCLbl lbl2), NOP,
2789 OR False g0 (RIImm (ImmInt 1)) dst,
2792 returnNat (Any IntRep code__2)
2794 #endif {- sparc_TARGET_ARCH -}
2797 %************************************************************************
2799 \subsubsection{@trivial*Code@: deal with trivial instructions}
2801 %************************************************************************
2803 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2804 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2805 for constants on the right hand side, because that's where the generic
2806 optimizer will have put them.
2808 Similarly, for unary instructions, we don't have to worry about
2809 matching an StInt as the argument, because genericOpt will already
2810 have handled the constant-folding.
2814 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2815 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2816 -> Maybe (Operand -> Operand -> Instr)
2817 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2819 -> StixTree -> StixTree -- the two arguments
2824 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2825 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2826 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2828 -> StixTree -> StixTree -- the two arguments
2832 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2833 ,IF_ARCH_i386 ((Operand -> Instr)
2834 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2836 -> StixTree -- the one argument
2841 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2842 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2843 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2845 -> StixTree -- the one argument
2848 #if alpha_TARGET_ARCH
2850 trivialCode instr x (StInt y)
2852 = getRegister x `thenNat` \ register ->
2853 getNewRegNCG IntRep `thenNat` \ tmp ->
2855 code = registerCode register tmp
2856 src1 = registerName register tmp
2857 src2 = ImmInt (fromInteger y)
2858 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2860 returnNat (Any IntRep code__2)
2862 trivialCode instr x y
2863 = getRegister x `thenNat` \ register1 ->
2864 getRegister y `thenNat` \ register2 ->
2865 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2866 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2868 code1 = registerCode register1 tmp1 []
2869 src1 = registerName register1 tmp1
2870 code2 = registerCode register2 tmp2 []
2871 src2 = registerName register2 tmp2
2872 code__2 dst = asmSeqThen [code1, code2] .
2873 mkSeqInstr (instr src1 (RIReg src2) dst)
2875 returnNat (Any IntRep code__2)
2878 trivialUCode instr x
2879 = getRegister x `thenNat` \ register ->
2880 getNewRegNCG IntRep `thenNat` \ tmp ->
2882 code = registerCode register tmp
2883 src = registerName register tmp
2884 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2886 returnNat (Any IntRep code__2)
2889 trivialFCode _ instr x y
2890 = getRegister x `thenNat` \ register1 ->
2891 getRegister y `thenNat` \ register2 ->
2892 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2893 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2895 code1 = registerCode register1 tmp1
2896 src1 = registerName register1 tmp1
2898 code2 = registerCode register2 tmp2
2899 src2 = registerName register2 tmp2
2901 code__2 dst = asmSeqThen [code1 [], code2 []] .
2902 mkSeqInstr (instr src1 src2 dst)
2904 returnNat (Any DoubleRep code__2)
2906 trivialUFCode _ instr x
2907 = getRegister x `thenNat` \ register ->
2908 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2910 code = registerCode register tmp
2911 src = registerName register tmp
2912 code__2 dst = code . mkSeqInstr (instr src dst)
2914 returnNat (Any DoubleRep code__2)
2916 #endif {- alpha_TARGET_ARCH -}
2917 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2918 #if i386_TARGET_ARCH
2920 The Rules of the Game are:
2922 * You cannot assume anything about the destination register dst;
2923 it may be anything, including a fixed reg.
2925 * You may compute an operand into a fixed reg, but you may not
2926 subsequently change the contents of that fixed reg. If you
2927 want to do so, first copy the value either to a temporary
2928 or into dst. You are free to modify dst even if it happens
2929 to be a fixed reg -- that's not your problem.
2931 * You cannot assume that a fixed reg will stay live over an
2932 arbitrary computation. The same applies to the dst reg.
2934 * Temporary regs obtained from getNewRegNCG are distinct from
2935 each other and from all other regs, and stay live over
2936 arbitrary computations.
2940 trivialCode instr maybe_revinstr a b
2943 = getRegister a `thenNat` \ rega ->
2946 then registerCode rega dst `bind` \ code_a ->
2948 instr (OpImm imm_b) (OpReg dst)
2949 else registerCodeF rega `bind` \ code_a ->
2950 registerNameF rega `bind` \ r_a ->
2952 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2953 instr (OpImm imm_b) (OpReg dst)
2955 returnNat (Any IntRep mkcode)
2958 = getRegister b `thenNat` \ regb ->
2959 getNewRegNCG IntRep `thenNat` \ tmp ->
2960 let revinstr_avail = maybeToBool maybe_revinstr
2961 revinstr = case maybe_revinstr of Just ri -> ri
2965 then registerCode regb dst `bind` \ code_b ->
2967 revinstr (OpImm imm_a) (OpReg dst)
2968 else registerCodeF regb `bind` \ code_b ->
2969 registerNameF regb `bind` \ r_b ->
2971 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2972 revinstr (OpImm imm_a) (OpReg dst)
2976 then registerCode regb tmp `bind` \ code_b ->
2978 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2979 instr (OpReg tmp) (OpReg dst)
2980 else registerCodeF regb `bind` \ code_b ->
2981 registerNameF regb `bind` \ r_b ->
2983 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2984 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2985 instr (OpReg tmp) (OpReg dst)
2987 returnNat (Any IntRep mkcode)
2990 = getRegister a `thenNat` \ rega ->
2991 getRegister b `thenNat` \ regb ->
2992 getNewRegNCG IntRep `thenNat` \ tmp ->
2994 = case (isAny rega, isAny regb) of
2996 -> registerCode regb tmp `bind` \ code_b ->
2997 registerCode rega dst `bind` \ code_a ->
3000 instr (OpReg tmp) (OpReg dst)
3002 -> registerCode rega tmp `bind` \ code_a ->
3003 registerCodeF regb `bind` \ code_b ->
3004 registerNameF regb `bind` \ r_b ->
3007 instr (OpReg r_b) (OpReg tmp) `snocOL`
3008 MOV L (OpReg tmp) (OpReg dst)
3010 -> registerCode regb tmp `bind` \ code_b ->
3011 registerCodeF rega `bind` \ code_a ->
3012 registerNameF rega `bind` \ r_a ->
3015 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3016 instr (OpReg tmp) (OpReg dst)
3018 -> registerCodeF rega `bind` \ code_a ->
3019 registerNameF rega `bind` \ r_a ->
3020 registerCodeF regb `bind` \ code_b ->
3021 registerNameF regb `bind` \ r_b ->
3023 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3025 instr (OpReg r_b) (OpReg tmp) `snocOL`
3026 MOV L (OpReg tmp) (OpReg dst)
3028 returnNat (Any IntRep mkcode)
3031 maybe_imm_a = maybeImm a
3032 is_imm_a = maybeToBool maybe_imm_a
3033 imm_a = case maybe_imm_a of Just imm -> imm
3035 maybe_imm_b = maybeImm b
3036 is_imm_b = maybeToBool maybe_imm_b
3037 imm_b = case maybe_imm_b of Just imm -> imm
3041 trivialUCode instr x
3042 = getRegister x `thenNat` \ register ->
3044 code__2 dst = let code = registerCode register dst
3045 src = registerName register dst
3047 if isFixed register && dst /= src
3048 then toOL [MOV L (OpReg src) (OpReg dst),
3050 else unitOL (instr (OpReg src))
3052 returnNat (Any IntRep code__2)
3055 trivialFCode pk instr x y
3056 = getRegister x `thenNat` \ register1 ->
3057 getRegister y `thenNat` \ register2 ->
3058 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3059 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3061 code1 = registerCode register1 tmp1
3062 src1 = registerName register1 tmp1
3064 code2 = registerCode register2 tmp2
3065 src2 = registerName register2 tmp2
3068 -- treat the common case specially: both operands in
3070 | isAny register1 && isAny register2
3073 instr (primRepToSize pk) src1 src2 dst
3075 -- be paranoid (and inefficient)
3077 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3079 instr (primRepToSize pk) tmp1 src2 dst
3081 returnNat (Any pk code__2)
3085 trivialUFCode pk instr x
3086 = getRegister x `thenNat` \ register ->
3087 getNewRegNCG pk `thenNat` \ tmp ->
3089 code = registerCode register tmp
3090 src = registerName register tmp
3091 code__2 dst = code `snocOL` instr src dst
3093 returnNat (Any pk code__2)
3095 #endif {- i386_TARGET_ARCH -}
3096 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3097 #if sparc_TARGET_ARCH
3099 trivialCode instr x (StInt y)
3101 = getRegister x `thenNat` \ register ->
3102 getNewRegNCG IntRep `thenNat` \ tmp ->
3104 code = registerCode register tmp
3105 src1 = registerName register tmp
3106 src2 = ImmInt (fromInteger y)
3107 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3109 returnNat (Any IntRep code__2)
3111 trivialCode instr x y
3112 = getRegister x `thenNat` \ register1 ->
3113 getRegister y `thenNat` \ register2 ->
3114 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3115 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3117 code1 = registerCode register1 tmp1
3118 src1 = registerName register1 tmp1
3119 code2 = registerCode register2 tmp2
3120 src2 = registerName register2 tmp2
3121 code__2 dst = code1 `appOL` code2 `snocOL`
3122 instr src1 (RIReg src2) dst
3124 returnNat (Any IntRep code__2)
3127 trivialFCode pk instr x y
3128 = getRegister x `thenNat` \ register1 ->
3129 getRegister y `thenNat` \ register2 ->
3130 getNewRegNCG (registerRep register1)
3132 getNewRegNCG (registerRep register2)
3134 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3136 promote x = FxTOy F DF x tmp
3138 pk1 = registerRep register1
3139 code1 = registerCode register1 tmp1
3140 src1 = registerName register1 tmp1
3142 pk2 = registerRep register2
3143 code2 = registerCode register2 tmp2
3144 src2 = registerName register2 tmp2
3148 code1 `appOL` code2 `snocOL`
3149 instr (primRepToSize pk) src1 src2 dst
3150 else if pk1 == FloatRep then
3151 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3152 instr DF tmp src2 dst
3154 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3155 instr DF src1 tmp dst
3157 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3160 trivialUCode instr x
3161 = getRegister x `thenNat` \ register ->
3162 getNewRegNCG IntRep `thenNat` \ tmp ->
3164 code = registerCode register tmp
3165 src = registerName register tmp
3166 code__2 dst = code `snocOL` instr (RIReg src) dst
3168 returnNat (Any IntRep code__2)
3171 trivialUFCode pk instr x
3172 = getRegister x `thenNat` \ register ->
3173 getNewRegNCG pk `thenNat` \ tmp ->
3175 code = registerCode register tmp
3176 src = registerName register tmp
3177 code__2 dst = code `snocOL` instr src dst
3179 returnNat (Any pk code__2)
3181 #endif {- sparc_TARGET_ARCH -}
3184 %************************************************************************
3186 \subsubsection{Coercing to/from integer/floating-point...}
3188 %************************************************************************
3190 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3191 to be generated. Here we just change the type on the Register passed
3192 on up. The code is machine-independent.
3194 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3195 conversions. We have to store temporaries in memory to move
3196 between the integer and the floating point register sets.
3199 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3200 coerceFltCode :: StixTree -> NatM Register
3202 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3203 coerceFP2Int :: StixTree -> NatM Register
3206 = getRegister x `thenNat` \ register ->
3209 Fixed _ reg code -> Fixed pk reg code
3210 Any _ code -> Any pk code
3215 = getRegister x `thenNat` \ register ->
3218 Fixed _ reg code -> Fixed DoubleRep reg code
3219 Any _ code -> Any DoubleRep code
3224 #if alpha_TARGET_ARCH
3227 = getRegister x `thenNat` \ register ->
3228 getNewRegNCG IntRep `thenNat` \ reg ->
3230 code = registerCode register reg
3231 src = registerName register reg
3233 code__2 dst = code . mkSeqInstrs [
3235 LD TF dst (spRel 0),
3238 returnNat (Any DoubleRep code__2)
3242 = getRegister x `thenNat` \ register ->
3243 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3245 code = registerCode register tmp
3246 src = registerName register tmp
3248 code__2 dst = code . mkSeqInstrs [
3250 ST TF tmp (spRel 0),
3253 returnNat (Any IntRep code__2)
3255 #endif {- alpha_TARGET_ARCH -}
3256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257 #if i386_TARGET_ARCH
3260 = getRegister x `thenNat` \ register ->
3261 getNewRegNCG IntRep `thenNat` \ reg ->
3263 code = registerCode register reg
3264 src = registerName register reg
3265 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3266 code__2 dst = code `snocOL` opc src dst
3268 returnNat (Any pk code__2)
3272 = getRegister x `thenNat` \ register ->
3273 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3275 code = registerCode register tmp
3276 src = registerName register tmp
3277 pk = registerRep register
3279 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3280 code__2 dst = code `snocOL` opc src dst
3282 returnNat (Any IntRep code__2)
3284 #endif {- i386_TARGET_ARCH -}
3285 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3286 #if sparc_TARGET_ARCH
3289 = getRegister x `thenNat` \ register ->
3290 getNewRegNCG IntRep `thenNat` \ reg ->
3292 code = registerCode register reg
3293 src = registerName register reg
3295 code__2 dst = code `appOL` toOL [
3296 ST W src (spRel (-2)),
3297 LD W (spRel (-2)) dst,
3298 FxTOy W (primRepToSize pk) dst dst]
3300 returnNat (Any pk code__2)
3304 = getRegister x `thenNat` \ register ->
3305 getNewRegNCG IntRep `thenNat` \ reg ->
3306 getNewRegNCG FloatRep `thenNat` \ tmp ->
3308 code = registerCode register reg
3309 src = registerName register reg
3310 pk = registerRep register
3312 code__2 dst = code `appOL` toOL [
3313 FxTOy (primRepToSize pk) W src tmp,
3314 ST W tmp (spRel (-2)),
3315 LD W (spRel (-2)) dst]
3317 returnNat (Any IntRep code__2)
3319 #endif {- sparc_TARGET_ARCH -}
3322 %************************************************************************
3324 \subsubsection{Coercing integer to @Char@...}
3326 %************************************************************************
3328 Integer to character conversion.
3331 chrCode :: StixTree -> NatM Register
3333 #if alpha_TARGET_ARCH
3335 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3336 -- It should coerce a 64-bit value to a 32-bit value.
3339 = getRegister x `thenNat` \ register ->
3340 getNewRegNCG IntRep `thenNat` \ reg ->
3342 code = registerCode register reg
3343 src = registerName register reg
3344 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3346 returnNat (Any IntRep code__2)
3348 #endif {- alpha_TARGET_ARCH -}
3349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3350 #if i386_TARGET_ARCH
3353 = getRegister x `thenNat` \ register ->
3356 Fixed _ reg code -> Fixed IntRep reg code
3357 Any _ code -> Any IntRep code
3360 #endif {- i386_TARGET_ARCH -}
3361 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3362 #if sparc_TARGET_ARCH
3365 = getRegister x `thenNat` \ register ->
3368 Fixed _ reg code -> Fixed IntRep reg code
3369 Any _ code -> Any IntRep code
3372 #endif {- sparc_TARGET_ARCH -}