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 -- Deallocate parameters after call for ccall;
2445 -- but not for stdcall (callee does it)
2446 (if cconv == StdCallConv then [] else
2447 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2450 [DELTA (delta + tot_arg_size)]
2453 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2454 returnNat (code2 `appOL` call)
2457 -- function names that begin with '.' are assumed to be special
2458 -- internally generated names like '.mul,' which don't get an
2459 -- underscore prefix
2460 -- ToDo:needed (WDP 96/03) ???
2464 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2465 | otherwise -- General case
2466 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2468 stdcallsize tot_arg_size
2469 | cconv == StdCallConv = '@':show tot_arg_size
2477 get_call_arg :: StixTree{-current argument-}
2478 -> NatM (Int, InstrBlock) -- argsz, code
2481 = get_op arg `thenNat` \ (code, reg, sz) ->
2482 getDeltaNat `thenNat` \ delta ->
2483 arg_size sz `bind` \ size ->
2484 setDeltaNat (delta-size) `thenNat` \ _ ->
2485 if (case sz of DF -> True; F -> True; _ -> False)
2486 then returnNat (size,
2488 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2490 GST sz reg (AddrBaseIndex (Just esp)
2494 else returnNat (size,
2496 PUSH L (OpReg reg) `snocOL`
2502 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2505 = getRegister op `thenNat` \ register ->
2506 getNewRegNCG (registerRep register)
2509 code = registerCode register tmp
2510 reg = registerName register tmp
2511 pk = registerRep register
2512 sz = primRepToSize pk
2514 returnNat (code, reg, sz)
2516 #endif {- i386_TARGET_ARCH -}
2517 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2518 #if sparc_TARGET_ARCH
2520 The SPARC calling convention is an absolute
2521 nightmare. The first 6x32 bits of arguments are mapped into
2522 %o0 through %o5, and the remaining arguments are dumped to the
2523 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2525 If we have to put args on the stack, move %o6==%sp down by
2526 the number of words to go on the stack, to ensure there's enough space.
2528 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2529 16 words above the stack pointer is a word for the address of
2530 a structure return value. I use this as a temporary location
2531 for moving values from float to int regs. Certainly it isn't
2532 safe to put anything in the 16 words starting at %sp, since
2533 this area can get trashed at any time due to window overflows
2534 caused by signal handlers.
2536 A final complication (if the above isn't enough) is that
2537 we can't blithely calculate the arguments one by one into
2538 %o0 .. %o5. Consider the following nested calls:
2542 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2543 the inner call will itself use %o0, which trashes the value put there
2544 in preparation for the outer call. Upshot: we need to calculate the
2545 args into temporary regs, and move those to arg regs or onto the
2546 stack only immediately prior to the call proper. Sigh.
2549 genCCall fn cconv kind args
2550 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2551 let (argcodes, vregss) = unzip argcode_and_vregs
2552 argcode = concatOL argcodes
2553 vregs = concat vregss
2554 n_argRegs = length allArgRegs
2555 n_argRegs_used = min (length vregs) n_argRegs
2556 (move_sp_down, move_sp_up)
2557 = let nn = length vregs - n_argRegs
2558 + 1 -- (for the road)
2561 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2563 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2565 = unitOL (CALL fn__2 n_argRegs_used False)
2567 returnNat (argcode `appOL`
2568 move_sp_down `appOL`
2569 transfer_code `appOL`
2574 -- function names that begin with '.' are assumed to be special
2575 -- internally generated names like '.mul,' which don't get an
2576 -- underscore prefix
2577 -- ToDo:needed (WDP 96/03) ???
2578 fn__2 = case (_HEAD_ fn) of
2579 '.' -> ImmLit (ptext fn)
2580 _ -> ImmLab False (ptext fn)
2582 -- move args from the integer vregs into which they have been
2583 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2584 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2586 move_final [] _ offset -- all args done
2589 move_final (v:vs) [] offset -- out of aregs; move to stack
2590 = ST W v (spRel offset)
2591 : move_final vs [] (offset+1)
2593 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2594 = OR False g0 (RIReg v) a
2595 : move_final vs az offset
2597 -- generate code to calculate an argument, and move it into one
2598 -- or two integer vregs.
2599 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2600 arg_to_int_vregs arg
2601 = getRegister arg `thenNat` \ register ->
2602 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2603 let code = registerCode register tmp
2604 src = registerName register tmp
2605 pk = registerRep register
2607 -- the value is in src. Get it into 1 or 2 int vregs.
2610 getNewRegNCG WordRep `thenNat` \ v1 ->
2611 getNewRegNCG WordRep `thenNat` \ v2 ->
2614 FMOV DF src f0 `snocOL`
2615 ST F f0 (spRel 16) `snocOL`
2616 LD W (spRel 16) v1 `snocOL`
2617 ST F (fPair f0) (spRel 16) `snocOL`
2623 getNewRegNCG WordRep `thenNat` \ v1 ->
2626 ST F src (spRel 16) `snocOL`
2632 getNewRegNCG WordRep `thenNat` \ v1 ->
2634 code `snocOL` OR False g0 (RIReg src) v1
2638 #endif {- sparc_TARGET_ARCH -}
2641 %************************************************************************
2643 \subsection{Support bits}
2645 %************************************************************************
2647 %************************************************************************
2649 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2651 %************************************************************************
2653 Turn those condition codes into integers now (when they appear on
2654 the right hand side of an assignment).
2656 (If applicable) Do not fill the delay slots here; you will confuse the
2660 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2662 #if alpha_TARGET_ARCH
2663 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2664 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2665 #endif {- alpha_TARGET_ARCH -}
2667 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2668 #if i386_TARGET_ARCH
2671 = condIntCode cond x y `thenNat` \ condition ->
2672 getNewRegNCG IntRep `thenNat` \ tmp ->
2674 code = condCode condition
2675 cond = condName condition
2676 code__2 dst = code `appOL` toOL [
2677 SETCC cond (OpReg tmp),
2678 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2679 MOV L (OpReg tmp) (OpReg dst)]
2681 returnNat (Any IntRep code__2)
2684 = getNatLabelNCG `thenNat` \ lbl1 ->
2685 getNatLabelNCG `thenNat` \ lbl2 ->
2686 condFltCode cond x y `thenNat` \ condition ->
2688 code = condCode condition
2689 cond = condName condition
2690 code__2 dst = code `appOL` toOL [
2692 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2695 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2698 returnNat (Any IntRep code__2)
2700 #endif {- i386_TARGET_ARCH -}
2701 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2702 #if sparc_TARGET_ARCH
2704 condIntReg EQQ x (StInt 0)
2705 = getRegister x `thenNat` \ register ->
2706 getNewRegNCG IntRep `thenNat` \ tmp ->
2708 code = registerCode register tmp
2709 src = registerName register tmp
2710 code__2 dst = code `appOL` toOL [
2711 SUB False True g0 (RIReg src) g0,
2712 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2714 returnNat (Any IntRep code__2)
2717 = getRegister x `thenNat` \ register1 ->
2718 getRegister y `thenNat` \ register2 ->
2719 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2720 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2722 code1 = registerCode register1 tmp1
2723 src1 = registerName register1 tmp1
2724 code2 = registerCode register2 tmp2
2725 src2 = registerName register2 tmp2
2726 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2727 XOR False src1 (RIReg src2) dst,
2728 SUB False True g0 (RIReg dst) g0,
2729 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2731 returnNat (Any IntRep code__2)
2733 condIntReg NE x (StInt 0)
2734 = getRegister x `thenNat` \ register ->
2735 getNewRegNCG IntRep `thenNat` \ tmp ->
2737 code = registerCode register tmp
2738 src = registerName register tmp
2739 code__2 dst = code `appOL` toOL [
2740 SUB False True g0 (RIReg src) g0,
2741 ADD True False g0 (RIImm (ImmInt 0)) dst]
2743 returnNat (Any IntRep code__2)
2746 = getRegister x `thenNat` \ register1 ->
2747 getRegister y `thenNat` \ register2 ->
2748 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2749 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2751 code1 = registerCode register1 tmp1
2752 src1 = registerName register1 tmp1
2753 code2 = registerCode register2 tmp2
2754 src2 = registerName register2 tmp2
2755 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2756 XOR False src1 (RIReg src2) dst,
2757 SUB False True g0 (RIReg dst) g0,
2758 ADD True False g0 (RIImm (ImmInt 0)) dst]
2760 returnNat (Any IntRep code__2)
2763 = getNatLabelNCG `thenNat` \ lbl1 ->
2764 getNatLabelNCG `thenNat` \ lbl2 ->
2765 condIntCode cond x y `thenNat` \ condition ->
2767 code = condCode condition
2768 cond = condName condition
2769 code__2 dst = code `appOL` toOL [
2770 BI cond False (ImmCLbl lbl1), NOP,
2771 OR False g0 (RIImm (ImmInt 0)) dst,
2772 BI ALWAYS False (ImmCLbl lbl2), NOP,
2774 OR False g0 (RIImm (ImmInt 1)) dst,
2777 returnNat (Any IntRep code__2)
2780 = getNatLabelNCG `thenNat` \ lbl1 ->
2781 getNatLabelNCG `thenNat` \ lbl2 ->
2782 condFltCode cond x y `thenNat` \ condition ->
2784 code = condCode condition
2785 cond = condName condition
2786 code__2 dst = code `appOL` toOL [
2788 BF cond False (ImmCLbl lbl1), NOP,
2789 OR False g0 (RIImm (ImmInt 0)) dst,
2790 BI ALWAYS False (ImmCLbl lbl2), NOP,
2792 OR False g0 (RIImm (ImmInt 1)) dst,
2795 returnNat (Any IntRep code__2)
2797 #endif {- sparc_TARGET_ARCH -}
2800 %************************************************************************
2802 \subsubsection{@trivial*Code@: deal with trivial instructions}
2804 %************************************************************************
2806 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2807 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2808 for constants on the right hand side, because that's where the generic
2809 optimizer will have put them.
2811 Similarly, for unary instructions, we don't have to worry about
2812 matching an StInt as the argument, because genericOpt will already
2813 have handled the constant-folding.
2817 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2818 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2819 -> Maybe (Operand -> Operand -> Instr)
2820 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2822 -> StixTree -> StixTree -- the two arguments
2827 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2828 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2829 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2831 -> StixTree -> StixTree -- the two arguments
2835 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2836 ,IF_ARCH_i386 ((Operand -> Instr)
2837 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2839 -> StixTree -- the one argument
2844 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2845 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2846 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2848 -> StixTree -- the one argument
2851 #if alpha_TARGET_ARCH
2853 trivialCode instr x (StInt y)
2855 = getRegister x `thenNat` \ register ->
2856 getNewRegNCG IntRep `thenNat` \ tmp ->
2858 code = registerCode register tmp
2859 src1 = registerName register tmp
2860 src2 = ImmInt (fromInteger y)
2861 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2863 returnNat (Any IntRep code__2)
2865 trivialCode instr x y
2866 = getRegister x `thenNat` \ register1 ->
2867 getRegister y `thenNat` \ register2 ->
2868 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2869 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2871 code1 = registerCode register1 tmp1 []
2872 src1 = registerName register1 tmp1
2873 code2 = registerCode register2 tmp2 []
2874 src2 = registerName register2 tmp2
2875 code__2 dst = asmSeqThen [code1, code2] .
2876 mkSeqInstr (instr src1 (RIReg src2) dst)
2878 returnNat (Any IntRep code__2)
2881 trivialUCode instr x
2882 = getRegister x `thenNat` \ register ->
2883 getNewRegNCG IntRep `thenNat` \ tmp ->
2885 code = registerCode register tmp
2886 src = registerName register tmp
2887 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2889 returnNat (Any IntRep code__2)
2892 trivialFCode _ instr x y
2893 = getRegister x `thenNat` \ register1 ->
2894 getRegister y `thenNat` \ register2 ->
2895 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2896 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2898 code1 = registerCode register1 tmp1
2899 src1 = registerName register1 tmp1
2901 code2 = registerCode register2 tmp2
2902 src2 = registerName register2 tmp2
2904 code__2 dst = asmSeqThen [code1 [], code2 []] .
2905 mkSeqInstr (instr src1 src2 dst)
2907 returnNat (Any DoubleRep code__2)
2909 trivialUFCode _ instr x
2910 = getRegister x `thenNat` \ register ->
2911 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2913 code = registerCode register tmp
2914 src = registerName register tmp
2915 code__2 dst = code . mkSeqInstr (instr src dst)
2917 returnNat (Any DoubleRep code__2)
2919 #endif {- alpha_TARGET_ARCH -}
2920 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2921 #if i386_TARGET_ARCH
2923 The Rules of the Game are:
2925 * You cannot assume anything about the destination register dst;
2926 it may be anything, including a fixed reg.
2928 * You may compute an operand into a fixed reg, but you may not
2929 subsequently change the contents of that fixed reg. If you
2930 want to do so, first copy the value either to a temporary
2931 or into dst. You are free to modify dst even if it happens
2932 to be a fixed reg -- that's not your problem.
2934 * You cannot assume that a fixed reg will stay live over an
2935 arbitrary computation. The same applies to the dst reg.
2937 * Temporary regs obtained from getNewRegNCG are distinct from
2938 each other and from all other regs, and stay live over
2939 arbitrary computations.
2943 trivialCode instr maybe_revinstr a b
2946 = getRegister a `thenNat` \ rega ->
2949 then registerCode rega dst `bind` \ code_a ->
2951 instr (OpImm imm_b) (OpReg dst)
2952 else registerCodeF rega `bind` \ code_a ->
2953 registerNameF rega `bind` \ r_a ->
2955 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2956 instr (OpImm imm_b) (OpReg dst)
2958 returnNat (Any IntRep mkcode)
2961 = getRegister b `thenNat` \ regb ->
2962 getNewRegNCG IntRep `thenNat` \ tmp ->
2963 let revinstr_avail = maybeToBool maybe_revinstr
2964 revinstr = case maybe_revinstr of Just ri -> ri
2968 then registerCode regb dst `bind` \ code_b ->
2970 revinstr (OpImm imm_a) (OpReg dst)
2971 else registerCodeF regb `bind` \ code_b ->
2972 registerNameF regb `bind` \ r_b ->
2974 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2975 revinstr (OpImm imm_a) (OpReg dst)
2979 then registerCode regb tmp `bind` \ code_b ->
2981 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2982 instr (OpReg tmp) (OpReg dst)
2983 else registerCodeF regb `bind` \ code_b ->
2984 registerNameF regb `bind` \ r_b ->
2986 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2987 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2988 instr (OpReg tmp) (OpReg dst)
2990 returnNat (Any IntRep mkcode)
2993 = getRegister a `thenNat` \ rega ->
2994 getRegister b `thenNat` \ regb ->
2995 getNewRegNCG IntRep `thenNat` \ tmp ->
2997 = case (isAny rega, isAny regb) of
2999 -> registerCode regb tmp `bind` \ code_b ->
3000 registerCode rega dst `bind` \ code_a ->
3003 instr (OpReg tmp) (OpReg dst)
3005 -> registerCode rega tmp `bind` \ code_a ->
3006 registerCodeF regb `bind` \ code_b ->
3007 registerNameF regb `bind` \ r_b ->
3010 instr (OpReg r_b) (OpReg tmp) `snocOL`
3011 MOV L (OpReg tmp) (OpReg dst)
3013 -> registerCode regb tmp `bind` \ code_b ->
3014 registerCodeF rega `bind` \ code_a ->
3015 registerNameF rega `bind` \ r_a ->
3018 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3019 instr (OpReg tmp) (OpReg dst)
3021 -> registerCodeF rega `bind` \ code_a ->
3022 registerNameF rega `bind` \ r_a ->
3023 registerCodeF regb `bind` \ code_b ->
3024 registerNameF regb `bind` \ r_b ->
3026 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3028 instr (OpReg r_b) (OpReg tmp) `snocOL`
3029 MOV L (OpReg tmp) (OpReg dst)
3031 returnNat (Any IntRep mkcode)
3034 maybe_imm_a = maybeImm a
3035 is_imm_a = maybeToBool maybe_imm_a
3036 imm_a = case maybe_imm_a of Just imm -> imm
3038 maybe_imm_b = maybeImm b
3039 is_imm_b = maybeToBool maybe_imm_b
3040 imm_b = case maybe_imm_b of Just imm -> imm
3044 trivialUCode instr x
3045 = getRegister x `thenNat` \ register ->
3047 code__2 dst = let code = registerCode register dst
3048 src = registerName register dst
3050 if isFixed register && dst /= src
3051 then toOL [MOV L (OpReg src) (OpReg dst),
3053 else unitOL (instr (OpReg src))
3055 returnNat (Any IntRep code__2)
3058 trivialFCode pk instr x y
3059 = getRegister x `thenNat` \ register1 ->
3060 getRegister y `thenNat` \ register2 ->
3061 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3062 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3064 code1 = registerCode register1 tmp1
3065 src1 = registerName register1 tmp1
3067 code2 = registerCode register2 tmp2
3068 src2 = registerName register2 tmp2
3071 -- treat the common case specially: both operands in
3073 | isAny register1 && isAny register2
3076 instr (primRepToSize pk) src1 src2 dst
3078 -- be paranoid (and inefficient)
3080 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3082 instr (primRepToSize pk) tmp1 src2 dst
3084 returnNat (Any pk code__2)
3088 trivialUFCode pk instr x
3089 = getRegister x `thenNat` \ register ->
3090 getNewRegNCG pk `thenNat` \ tmp ->
3092 code = registerCode register tmp
3093 src = registerName register tmp
3094 code__2 dst = code `snocOL` instr src dst
3096 returnNat (Any pk code__2)
3098 #endif {- i386_TARGET_ARCH -}
3099 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3100 #if sparc_TARGET_ARCH
3102 trivialCode instr x (StInt y)
3104 = getRegister x `thenNat` \ register ->
3105 getNewRegNCG IntRep `thenNat` \ tmp ->
3107 code = registerCode register tmp
3108 src1 = registerName register tmp
3109 src2 = ImmInt (fromInteger y)
3110 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3112 returnNat (Any IntRep code__2)
3114 trivialCode instr x y
3115 = getRegister x `thenNat` \ register1 ->
3116 getRegister y `thenNat` \ register2 ->
3117 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3118 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3120 code1 = registerCode register1 tmp1
3121 src1 = registerName register1 tmp1
3122 code2 = registerCode register2 tmp2
3123 src2 = registerName register2 tmp2
3124 code__2 dst = code1 `appOL` code2 `snocOL`
3125 instr src1 (RIReg src2) dst
3127 returnNat (Any IntRep code__2)
3130 trivialFCode pk instr x y
3131 = getRegister x `thenNat` \ register1 ->
3132 getRegister y `thenNat` \ register2 ->
3133 getNewRegNCG (registerRep register1)
3135 getNewRegNCG (registerRep register2)
3137 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3139 promote x = FxTOy F DF x tmp
3141 pk1 = registerRep register1
3142 code1 = registerCode register1 tmp1
3143 src1 = registerName register1 tmp1
3145 pk2 = registerRep register2
3146 code2 = registerCode register2 tmp2
3147 src2 = registerName register2 tmp2
3151 code1 `appOL` code2 `snocOL`
3152 instr (primRepToSize pk) src1 src2 dst
3153 else if pk1 == FloatRep then
3154 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3155 instr DF tmp src2 dst
3157 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3158 instr DF src1 tmp dst
3160 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3163 trivialUCode instr x
3164 = getRegister x `thenNat` \ register ->
3165 getNewRegNCG IntRep `thenNat` \ tmp ->
3167 code = registerCode register tmp
3168 src = registerName register tmp
3169 code__2 dst = code `snocOL` instr (RIReg src) dst
3171 returnNat (Any IntRep code__2)
3174 trivialUFCode pk instr x
3175 = getRegister x `thenNat` \ register ->
3176 getNewRegNCG pk `thenNat` \ tmp ->
3178 code = registerCode register tmp
3179 src = registerName register tmp
3180 code__2 dst = code `snocOL` instr src dst
3182 returnNat (Any pk code__2)
3184 #endif {- sparc_TARGET_ARCH -}
3187 %************************************************************************
3189 \subsubsection{Coercing to/from integer/floating-point...}
3191 %************************************************************************
3193 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3194 to be generated. Here we just change the type on the Register passed
3195 on up. The code is machine-independent.
3197 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3198 conversions. We have to store temporaries in memory to move
3199 between the integer and the floating point register sets.
3202 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3203 coerceFltCode :: StixTree -> NatM Register
3205 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3206 coerceFP2Int :: StixTree -> NatM Register
3209 = getRegister x `thenNat` \ register ->
3212 Fixed _ reg code -> Fixed pk reg code
3213 Any _ code -> Any pk code
3218 = getRegister x `thenNat` \ register ->
3221 Fixed _ reg code -> Fixed DoubleRep reg code
3222 Any _ code -> Any DoubleRep code
3227 #if alpha_TARGET_ARCH
3230 = getRegister x `thenNat` \ register ->
3231 getNewRegNCG IntRep `thenNat` \ reg ->
3233 code = registerCode register reg
3234 src = registerName register reg
3236 code__2 dst = code . mkSeqInstrs [
3238 LD TF dst (spRel 0),
3241 returnNat (Any DoubleRep code__2)
3245 = getRegister x `thenNat` \ register ->
3246 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3248 code = registerCode register tmp
3249 src = registerName register tmp
3251 code__2 dst = code . mkSeqInstrs [
3253 ST TF tmp (spRel 0),
3256 returnNat (Any IntRep code__2)
3258 #endif {- alpha_TARGET_ARCH -}
3259 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3260 #if i386_TARGET_ARCH
3263 = getRegister x `thenNat` \ register ->
3264 getNewRegNCG IntRep `thenNat` \ reg ->
3266 code = registerCode register reg
3267 src = registerName register reg
3268 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3269 code__2 dst = code `snocOL` opc src dst
3271 returnNat (Any pk code__2)
3275 = getRegister x `thenNat` \ register ->
3276 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3278 code = registerCode register tmp
3279 src = registerName register tmp
3280 pk = registerRep register
3282 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3283 code__2 dst = code `snocOL` opc src dst
3285 returnNat (Any IntRep code__2)
3287 #endif {- i386_TARGET_ARCH -}
3288 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3289 #if sparc_TARGET_ARCH
3292 = getRegister x `thenNat` \ register ->
3293 getNewRegNCG IntRep `thenNat` \ reg ->
3295 code = registerCode register reg
3296 src = registerName register reg
3298 code__2 dst = code `appOL` toOL [
3299 ST W src (spRel (-2)),
3300 LD W (spRel (-2)) dst,
3301 FxTOy W (primRepToSize pk) dst dst]
3303 returnNat (Any pk code__2)
3307 = getRegister x `thenNat` \ register ->
3308 getNewRegNCG IntRep `thenNat` \ reg ->
3309 getNewRegNCG FloatRep `thenNat` \ tmp ->
3311 code = registerCode register reg
3312 src = registerName register reg
3313 pk = registerRep register
3315 code__2 dst = code `appOL` toOL [
3316 FxTOy (primRepToSize pk) W src tmp,
3317 ST W tmp (spRel (-2)),
3318 LD W (spRel (-2)) dst]
3320 returnNat (Any IntRep code__2)
3322 #endif {- sparc_TARGET_ARCH -}
3325 %************************************************************************
3327 \subsubsection{Coercing integer to @Char@...}
3329 %************************************************************************
3331 Integer to character conversion.
3334 chrCode :: StixTree -> NatM Register
3336 #if alpha_TARGET_ARCH
3338 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3339 -- It should coerce a 64-bit value to a 32-bit value.
3342 = getRegister x `thenNat` \ register ->
3343 getNewRegNCG IntRep `thenNat` \ reg ->
3345 code = registerCode register reg
3346 src = registerName register reg
3347 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3349 returnNat (Any IntRep code__2)
3351 #endif {- alpha_TARGET_ARCH -}
3352 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3353 #if i386_TARGET_ARCH
3356 = getRegister x `thenNat` \ register ->
3359 Fixed _ reg code -> Fixed IntRep reg code
3360 Any _ code -> Any IntRep code
3363 #endif {- i386_TARGET_ARCH -}
3364 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3365 #if sparc_TARGET_ARCH
3368 = getRegister x `thenNat` \ register ->
3371 Fixed _ reg code -> Fixed IntRep reg code
3372 Any _ code -> Any IntRep code
3375 #endif {- sparc_TARGET_ARCH -}