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 ( stmt2Instrs, 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 AbsCSyn ( MagicId )
22 import AbsCUtils ( magicIdPrimRep )
23 import CallConv ( CallConv )
24 import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
25 import Maybes ( maybeToBool, expectJust )
26 import PrimRep ( isFloatingRep, PrimRep(..) )
27 import PrimOp ( PrimOp(..) )
28 import CallConv ( cCallConv )
29 import Stix ( getNatLabelNCG, StixTree(..),
30 StixReg(..), CodeSegment(..),
31 pprStixTree, ppStixReg,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
61 stmt2Instrs stmt = case stmt of
62 StComment s -> returnNat (unitOL (COMMENT s))
63 StSegment seg -> returnNat (unitOL (SEGMENT seg))
65 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
67 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
70 StLabel lab -> returnNat (unitOL (LABEL lab))
72 StJump arg -> genJump (derefDLL arg)
73 StCondJump lab arg -> genCondJump lab (derefDLL arg)
75 -- A call returning void, ie one done for its side-effects
76 StCall fn cconv VoidRep args -> genCCall fn
77 cconv VoidRep (map derefDLL args)
80 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
81 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
84 -- When falling through on the Alpha, we still have to load pv
85 -- with the address of the next routine, so that it can load gp.
86 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
90 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
91 returnNat (DATA (primRepToSize kind) imms
92 `consOL` concatOL codes)
94 getData :: StixTree -> NatM (InstrBlock, Imm)
96 getData (StInt i) = returnNat (nilOL, ImmInteger i)
97 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
98 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
99 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
100 getData (StString s) =
101 getNatLabelNCG `thenNat` \ lbl ->
102 returnNat (toOL [LABEL lbl,
103 ASCII True (_UNPK_ s)],
105 -- the linker can handle simple arithmetic...
106 getData (StIndex rep (StCLbl lbl) (StInt off)) =
108 ImmIndex lbl (fromInteger (off * sizeOf rep)))
110 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
111 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
112 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
114 derefDLL :: StixTree -> StixTree
116 | opt_Static -- short out the entire deal if not doing DLLs
123 StCLbl lbl -> if labelDynamic lbl
124 then StInd PtrRep (StCLbl lbl)
126 -- all the rest are boring
127 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
128 StPrim pk args -> StPrim pk (map qq args)
129 StInd pk addr -> StInd pk (qq addr)
130 StCall who cc pk args -> StCall who cc pk (map qq args)
137 _ -> pprPanic "derefDLL: unhandled case"
141 %************************************************************************
143 \subsection{General things for putting together code sequences}
145 %************************************************************************
148 mangleIndexTree :: StixTree -> StixTree
150 mangleIndexTree (StIndex pk base (StInt i))
151 = StPrim IntAddOp [base, off]
153 off = StInt (i * sizeOf pk)
155 mangleIndexTree (StIndex pk base off)
159 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
160 if s == 0 then off else StPrim SllOp [off, StInt s]
163 shift DoubleRep = 3::Integer
164 shift CharRep = 0::Integer
165 shift _ = IF_ARCH_alpha(3,2)
169 maybeImm :: StixTree -> Maybe Imm
173 maybeImm (StIndex rep (StCLbl l) (StInt off))
174 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
176 | i >= toInteger minInt && i <= toInteger maxInt
177 = Just (ImmInt (fromInteger i))
179 = Just (ImmInteger i)
184 %************************************************************************
186 \subsection{The @Register@ type}
188 %************************************************************************
190 @Register@s passed up the tree. If the stix code forces the register
191 to live in a pre-decided machine register, it comes out as @Fixed@;
192 otherwise, it comes out as @Any@, and the parent can decide which
193 register to put it in.
197 = Fixed PrimRep Reg InstrBlock
198 | Any PrimRep (Reg -> InstrBlock)
200 registerCode :: Register -> Reg -> InstrBlock
201 registerCode (Fixed _ _ code) reg = code
202 registerCode (Any _ code) reg = code reg
204 registerCodeF (Fixed _ _ code) = code
205 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
207 registerCodeA (Any _ code) = code
208 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
210 registerName :: Register -> Reg -> Reg
211 registerName (Fixed _ reg _) _ = reg
212 registerName (Any _ _) reg = reg
214 registerNameF (Fixed _ reg _) = reg
215 registerNameF (Any _ _) = pprPanic "registerNameF" empty
217 registerRep :: Register -> PrimRep
218 registerRep (Fixed pk _ _) = pk
219 registerRep (Any pk _) = pk
221 {-# INLINE registerCode #-}
222 {-# INLINE registerCodeF #-}
223 {-# INLINE registerName #-}
224 {-# INLINE registerNameF #-}
225 {-# INLINE registerRep #-}
226 {-# INLINE isFixed #-}
229 isFixed, isAny :: Register -> Bool
230 isFixed (Fixed _ _ _) = True
231 isFixed (Any _ _) = False
233 isAny = not . isFixed
236 Generate code to get a subtree into a @Register@:
238 getRegister :: StixTree -> NatM Register
240 getRegister (StReg (StixMagicId stgreg))
241 = case (magicIdRegMaybe stgreg) of
242 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
245 getRegister (StReg (StixTemp u pk))
246 = returnNat (Fixed pk (mkVReg u pk) nilOL)
248 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
250 getRegister (StCall fn cconv kind args)
251 = genCCall fn cconv kind args `thenNat` \ call ->
252 returnNat (Fixed kind reg call)
254 reg = if isFloatingRep kind
255 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
256 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
258 getRegister (StString s)
259 = getNatLabelNCG `thenNat` \ lbl ->
261 imm_lbl = ImmCLbl lbl
266 ASCII True (_UNPK_ s),
268 #if alpha_TARGET_ARCH
269 LDA dst (AddrImm imm_lbl)
272 MOV L (OpImm imm_lbl) (OpReg dst)
274 #if sparc_TARGET_ARCH
275 SETHI (HI imm_lbl) dst,
276 OR False dst (RIImm (LO imm_lbl)) dst
280 returnNat (Any PtrRep code)
284 -- end of machine-"independent" bit; here we go on the rest...
286 #if alpha_TARGET_ARCH
288 getRegister (StDouble d)
289 = getNatLabelNCG `thenNat` \ lbl ->
290 getNewRegNCG PtrRep `thenNat` \ tmp ->
291 let code dst = mkSeqInstrs [
294 DATA TF [ImmLab (rational d)],
296 LDA tmp (AddrImm (ImmCLbl lbl)),
297 LD TF dst (AddrReg tmp)]
299 returnNat (Any DoubleRep code)
301 getRegister (StPrim primop [x]) -- unary PrimOps
303 IntNegOp -> trivialUCode (NEG Q False) x
305 NotOp -> trivialUCode NOT x
307 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
308 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
310 OrdOp -> coerceIntCode IntRep x
313 Float2IntOp -> coerceFP2Int x
314 Int2FloatOp -> coerceInt2FP pr x
315 Double2IntOp -> coerceFP2Int x
316 Int2DoubleOp -> coerceInt2FP pr x
318 Double2FloatOp -> coerceFltCode x
319 Float2DoubleOp -> coerceFltCode x
321 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
323 fn = case other_op of
324 FloatExpOp -> SLIT("exp")
325 FloatLogOp -> SLIT("log")
326 FloatSqrtOp -> SLIT("sqrt")
327 FloatSinOp -> SLIT("sin")
328 FloatCosOp -> SLIT("cos")
329 FloatTanOp -> SLIT("tan")
330 FloatAsinOp -> SLIT("asin")
331 FloatAcosOp -> SLIT("acos")
332 FloatAtanOp -> SLIT("atan")
333 FloatSinhOp -> SLIT("sinh")
334 FloatCoshOp -> SLIT("cosh")
335 FloatTanhOp -> SLIT("tanh")
336 DoubleExpOp -> SLIT("exp")
337 DoubleLogOp -> SLIT("log")
338 DoubleSqrtOp -> SLIT("sqrt")
339 DoubleSinOp -> SLIT("sin")
340 DoubleCosOp -> SLIT("cos")
341 DoubleTanOp -> SLIT("tan")
342 DoubleAsinOp -> SLIT("asin")
343 DoubleAcosOp -> SLIT("acos")
344 DoubleAtanOp -> SLIT("atan")
345 DoubleSinhOp -> SLIT("sinh")
346 DoubleCoshOp -> SLIT("cosh")
347 DoubleTanhOp -> SLIT("tanh")
349 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
351 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
353 CharGtOp -> trivialCode (CMP LTT) y x
354 CharGeOp -> trivialCode (CMP LE) y x
355 CharEqOp -> trivialCode (CMP EQQ) x y
356 CharNeOp -> int_NE_code x y
357 CharLtOp -> trivialCode (CMP LTT) x y
358 CharLeOp -> trivialCode (CMP LE) x y
360 IntGtOp -> trivialCode (CMP LTT) y x
361 IntGeOp -> trivialCode (CMP LE) y x
362 IntEqOp -> trivialCode (CMP EQQ) x y
363 IntNeOp -> int_NE_code x y
364 IntLtOp -> trivialCode (CMP LTT) x y
365 IntLeOp -> trivialCode (CMP LE) x y
367 WordGtOp -> trivialCode (CMP ULT) y x
368 WordGeOp -> trivialCode (CMP ULE) x y
369 WordEqOp -> trivialCode (CMP EQQ) x y
370 WordNeOp -> int_NE_code x y
371 WordLtOp -> trivialCode (CMP ULT) x y
372 WordLeOp -> trivialCode (CMP ULE) x y
374 AddrGtOp -> trivialCode (CMP ULT) y x
375 AddrGeOp -> trivialCode (CMP ULE) y x
376 AddrEqOp -> trivialCode (CMP EQQ) x y
377 AddrNeOp -> int_NE_code x y
378 AddrLtOp -> trivialCode (CMP ULT) x y
379 AddrLeOp -> trivialCode (CMP ULE) x y
381 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
382 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
383 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
384 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
385 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
386 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
388 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
389 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
390 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
391 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
392 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
393 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
395 IntAddOp -> trivialCode (ADD Q False) x y
396 IntSubOp -> trivialCode (SUB Q False) x y
397 IntMulOp -> trivialCode (MUL Q False) x y
398 IntQuotOp -> trivialCode (DIV Q False) x y
399 IntRemOp -> trivialCode (REM Q False) x y
401 WordQuotOp -> trivialCode (DIV Q True) x y
402 WordRemOp -> trivialCode (REM Q True) x y
404 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
405 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
406 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
407 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
409 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
410 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
411 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
412 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
414 AndOp -> trivialCode AND x y
415 OrOp -> trivialCode OR x y
416 XorOp -> trivialCode XOR x y
417 SllOp -> trivialCode SLL x y
418 SrlOp -> trivialCode SRL x y
420 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
421 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
422 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
424 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
425 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
427 {- ------------------------------------------------------------
428 Some bizarre special code for getting condition codes into
429 registers. Integer non-equality is a test for equality
430 followed by an XOR with 1. (Integer comparisons always set
431 the result register to 0 or 1.) Floating point comparisons of
432 any kind leave the result in a floating point register, so we
433 need to wrangle an integer register out of things.
435 int_NE_code :: StixTree -> StixTree -> NatM Register
438 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
439 getNewRegNCG IntRep `thenNat` \ tmp ->
441 code = registerCode register tmp
442 src = registerName register tmp
443 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
445 returnNat (Any IntRep code__2)
447 {- ------------------------------------------------------------
448 Comments for int_NE_code also apply to cmpF_code
451 :: (Reg -> Reg -> Reg -> Instr)
453 -> StixTree -> StixTree
456 cmpF_code instr cond x y
457 = trivialFCode pr instr x y `thenNat` \ register ->
458 getNewRegNCG DoubleRep `thenNat` \ tmp ->
459 getNatLabelNCG `thenNat` \ lbl ->
461 code = registerCode register tmp
462 result = registerName register tmp
464 code__2 dst = code . mkSeqInstrs [
465 OR zeroh (RIImm (ImmInt 1)) dst,
466 BF cond result (ImmCLbl lbl),
467 OR zeroh (RIReg zeroh) dst,
470 returnNat (Any IntRep code__2)
472 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
473 ------------------------------------------------------------
475 getRegister (StInd pk mem)
476 = getAmode mem `thenNat` \ amode ->
478 code = amodeCode amode
479 src = amodeAddr amode
480 size = primRepToSize pk
481 code__2 dst = code . mkSeqInstr (LD size dst src)
483 returnNat (Any pk code__2)
485 getRegister (StInt i)
488 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
490 returnNat (Any IntRep code)
493 code dst = mkSeqInstr (LDI Q dst src)
495 returnNat (Any IntRep code)
497 src = ImmInt (fromInteger i)
502 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
504 returnNat (Any PtrRep code)
507 imm__2 = case imm of Just x -> x
509 #endif {- alpha_TARGET_ARCH -}
510 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
513 getRegister (StDouble d)
516 = let code dst = unitOL (GLDZ dst)
517 in returnNat (Any DoubleRep code)
520 = let code dst = unitOL (GLD1 dst)
521 in returnNat (Any DoubleRep code)
524 = getNatLabelNCG `thenNat` \ lbl ->
525 let code dst = toOL [
528 DATA DF [ImmDouble d],
530 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
533 returnNat (Any DoubleRep code)
535 -- Calculate the offset for (i+1) words above the _initial_
536 -- %esp value by first determining the current offset of it.
537 getRegister (StScratchWord i)
539 = getDeltaNat `thenNat` \ current_stack_offset ->
540 let j = i+1 - (current_stack_offset `div` 4)
542 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
544 returnNat (Any PtrRep code)
546 getRegister (StPrim primop [x]) -- unary PrimOps
548 IntNegOp -> trivialUCode (NEGI L) x
549 NotOp -> trivialUCode (NOT L) x
551 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
552 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
554 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
555 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
557 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
558 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
560 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
561 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
563 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
564 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
566 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
567 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
569 OrdOp -> coerceIntCode IntRep x
572 Float2IntOp -> coerceFP2Int x
573 Int2FloatOp -> coerceInt2FP FloatRep x
574 Double2IntOp -> coerceFP2Int x
575 Int2DoubleOp -> coerceInt2FP DoubleRep x
579 fixed_x = if is_float_op -- promote to double
580 then StPrim Float2DoubleOp [x]
583 getRegister (StCall fn cCallConv DoubleRep [x])
587 FloatExpOp -> (True, SLIT("exp"))
588 FloatLogOp -> (True, SLIT("log"))
590 FloatAsinOp -> (True, SLIT("asin"))
591 FloatAcosOp -> (True, SLIT("acos"))
592 FloatAtanOp -> (True, SLIT("atan"))
594 FloatSinhOp -> (True, SLIT("sinh"))
595 FloatCoshOp -> (True, SLIT("cosh"))
596 FloatTanhOp -> (True, SLIT("tanh"))
598 DoubleExpOp -> (False, SLIT("exp"))
599 DoubleLogOp -> (False, SLIT("log"))
601 DoubleAsinOp -> (False, SLIT("asin"))
602 DoubleAcosOp -> (False, SLIT("acos"))
603 DoubleAtanOp -> (False, SLIT("atan"))
605 DoubleSinhOp -> (False, SLIT("sinh"))
606 DoubleCoshOp -> (False, SLIT("cosh"))
607 DoubleTanhOp -> (False, SLIT("tanh"))
610 -> pprPanic "getRegister(x86,unary primop)"
611 (pprStixTree (StPrim primop [x]))
613 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
615 CharGtOp -> condIntReg GTT x y
616 CharGeOp -> condIntReg GE x y
617 CharEqOp -> condIntReg EQQ x y
618 CharNeOp -> condIntReg NE x y
619 CharLtOp -> condIntReg LTT x y
620 CharLeOp -> condIntReg LE x y
622 IntGtOp -> condIntReg GTT x y
623 IntGeOp -> condIntReg GE x y
624 IntEqOp -> condIntReg EQQ x y
625 IntNeOp -> condIntReg NE x y
626 IntLtOp -> condIntReg LTT x y
627 IntLeOp -> condIntReg LE x y
629 WordGtOp -> condIntReg GU x y
630 WordGeOp -> condIntReg GEU x y
631 WordEqOp -> condIntReg EQQ x y
632 WordNeOp -> condIntReg NE x y
633 WordLtOp -> condIntReg LU x y
634 WordLeOp -> condIntReg LEU x y
636 AddrGtOp -> condIntReg GU x y
637 AddrGeOp -> condIntReg GEU x y
638 AddrEqOp -> condIntReg EQQ x y
639 AddrNeOp -> condIntReg NE x y
640 AddrLtOp -> condIntReg LU x y
641 AddrLeOp -> condIntReg LEU x y
643 FloatGtOp -> condFltReg GTT x y
644 FloatGeOp -> condFltReg GE x y
645 FloatEqOp -> condFltReg EQQ x y
646 FloatNeOp -> condFltReg NE x y
647 FloatLtOp -> condFltReg LTT x y
648 FloatLeOp -> condFltReg LE x y
650 DoubleGtOp -> condFltReg GTT x y
651 DoubleGeOp -> condFltReg GE x y
652 DoubleEqOp -> condFltReg EQQ x y
653 DoubleNeOp -> condFltReg NE x y
654 DoubleLtOp -> condFltReg LTT x y
655 DoubleLeOp -> condFltReg LE x y
657 IntAddOp -> add_code L x y
658 IntSubOp -> sub_code L x y
659 IntQuotOp -> quot_code L x y True{-division-}
660 IntRemOp -> quot_code L x y False{-remainder-}
661 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
663 FloatAddOp -> trivialFCode FloatRep GADD x y
664 FloatSubOp -> trivialFCode FloatRep GSUB x y
665 FloatMulOp -> trivialFCode FloatRep GMUL x y
666 FloatDivOp -> trivialFCode FloatRep GDIV x y
668 DoubleAddOp -> trivialFCode DoubleRep GADD x y
669 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
670 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
671 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
673 AndOp -> let op = AND L in trivialCode op (Just op) x y
674 OrOp -> let op = OR L in trivialCode op (Just op) x y
675 XorOp -> let op = XOR L in trivialCode op (Just op) x y
677 {- Shift ops on x86s have constraints on their source, it
678 either has to be Imm, CL or 1
679 => trivialCode's is not restrictive enough (sigh.)
682 SllOp -> shift_code (SHL L) x y {-False-}
683 SrlOp -> shift_code (SHR L) x y {-False-}
684 ISllOp -> shift_code (SHL L) x y {-False-}
685 ISraOp -> shift_code (SAR L) x y {-False-}
686 ISrlOp -> shift_code (SHR L) x y {-False-}
688 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
689 [promote x, promote y])
690 where promote x = StPrim Float2DoubleOp [x]
691 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
694 -> pprPanic "getRegister(x86,dyadic primop)"
695 (pprStixTree (StPrim primop [x, y]))
699 shift_code :: (Imm -> Operand -> Instr)
704 {- Case1: shift length as immediate -}
705 -- Code is the same as the first eq. for trivialCode -- sigh.
706 shift_code instr x y{-amount-}
708 = getRegister x `thenNat` \ regx ->
711 then registerCodeA regx dst `bind` \ code_x ->
713 instr imm__2 (OpReg dst)
714 else registerCodeF regx `bind` \ code_x ->
715 registerNameF regx `bind` \ r_x ->
717 MOV L (OpReg r_x) (OpReg dst) `snocOL`
718 instr imm__2 (OpReg dst)
720 returnNat (Any IntRep mkcode)
723 imm__2 = case imm of Just x -> x
725 {- Case2: shift length is complex (non-immediate) -}
726 -- Since ECX is always used as a spill temporary, we can't
727 -- use it here to do non-immediate shifts. No big deal --
728 -- they are only very rare, and we can use an equivalent
729 -- test-and-jump sequence which doesn't use ECX.
730 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
731 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
732 shift_code instr x y{-amount-}
733 = getRegister x `thenNat` \ register1 ->
734 getRegister y `thenNat` \ register2 ->
735 getNatLabelNCG `thenNat` \ lbl_test3 ->
736 getNatLabelNCG `thenNat` \ lbl_test2 ->
737 getNatLabelNCG `thenNat` \ lbl_test1 ->
738 getNatLabelNCG `thenNat` \ lbl_test0 ->
739 getNatLabelNCG `thenNat` \ lbl_after ->
740 getNewRegNCG IntRep `thenNat` \ tmp ->
742 = let src_val = registerName register1 dst
743 code_val = registerCode register1 dst
744 src_amt = registerName register2 tmp
745 code_amt = registerCode register2 tmp
750 MOV L (OpReg src_amt) r_tmp `appOL`
752 MOV L (OpReg src_val) r_dst `appOL`
754 COMMENT (_PK_ "begin shift sequence"),
755 MOV L (OpReg src_val) r_dst,
756 MOV L (OpReg src_amt) r_tmp,
758 BT L (ImmInt 4) r_tmp,
760 instr (ImmInt 16) r_dst,
763 BT L (ImmInt 3) r_tmp,
765 instr (ImmInt 8) r_dst,
768 BT L (ImmInt 2) r_tmp,
770 instr (ImmInt 4) r_dst,
773 BT L (ImmInt 1) r_tmp,
775 instr (ImmInt 2) r_dst,
778 BT L (ImmInt 0) r_tmp,
780 instr (ImmInt 1) r_dst,
783 COMMENT (_PK_ "end shift sequence")
786 returnNat (Any IntRep code__2)
789 add_code :: Size -> StixTree -> StixTree -> NatM Register
791 add_code sz x (StInt y)
792 = getRegister x `thenNat` \ register ->
793 getNewRegNCG IntRep `thenNat` \ tmp ->
795 code = registerCode register tmp
796 src1 = registerName register tmp
797 src2 = ImmInt (fromInteger y)
800 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
803 returnNat (Any IntRep code__2)
805 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
808 sub_code :: Size -> StixTree -> StixTree -> NatM Register
810 sub_code sz x (StInt y)
811 = getRegister x `thenNat` \ register ->
812 getNewRegNCG IntRep `thenNat` \ tmp ->
814 code = registerCode register tmp
815 src1 = registerName register tmp
816 src2 = ImmInt (-(fromInteger y))
819 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
822 returnNat (Any IntRep code__2)
824 sub_code sz x y = trivialCode (SUB sz) Nothing x y
829 -> StixTree -> StixTree
830 -> Bool -- True => division, False => remainder operation
833 -- x must go into eax, edx must be a sign-extension of eax, and y
834 -- should go in some other register (or memory), so that we get
835 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
836 -- to put y on the C stack, since that avoids tying up yet another
837 -- precious register.
839 quot_code sz x y is_division
840 = getRegister x `thenNat` \ register1 ->
841 getRegister y `thenNat` \ register2 ->
842 getNewRegNCG IntRep `thenNat` \ tmp ->
843 getDeltaNat `thenNat` \ delta ->
845 code1 = registerCode register1 tmp
846 src1 = registerName register1 tmp
847 code2 = registerCode register2 tmp
848 src2 = registerName register2 tmp
849 code__2 = code2 `snocOL` -- src2 := y
850 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
851 DELTA (delta-4) `appOL`
852 code1 `snocOL` -- src1 := x
853 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
855 IDIV sz (OpAddr (spRel 0)) `snocOL`
856 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
859 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
860 -----------------------
862 getRegister (StInd pk mem)
863 = getAmode mem `thenNat` \ amode ->
865 code = amodeCode amode
866 src = amodeAddr amode
867 size = primRepToSize pk
868 code__2 dst = code `snocOL`
869 if pk == DoubleRep || pk == FloatRep
870 then GLD size src dst
872 L -> MOV L (OpAddr src) (OpReg dst)
873 B -> MOVZxL B (OpAddr src) (OpReg dst)
875 returnNat (Any pk code__2)
877 getRegister (StInt i)
879 src = ImmInt (fromInteger i)
882 = unitOL (XOR L (OpReg dst) (OpReg dst))
884 = unitOL (MOV L (OpImm src) (OpReg dst))
886 returnNat (Any IntRep code)
890 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
892 returnNat (Any PtrRep code)
894 = pprPanic "getRegister(x86)" (pprStixTree leaf)
897 imm__2 = case imm of Just x -> x
899 #endif {- i386_TARGET_ARCH -}
900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
901 #if sparc_TARGET_ARCH
903 getRegister (StFloat d)
904 = getNatLabelNCG `thenNat` \ lbl ->
905 getNewRegNCG PtrRep `thenNat` \ tmp ->
906 let code dst = toOL [
911 SETHI (HI (ImmCLbl lbl)) tmp,
912 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
914 returnNat (Any FloatRep code)
916 getRegister (StDouble d)
917 = getNatLabelNCG `thenNat` \ lbl ->
918 getNewRegNCG PtrRep `thenNat` \ tmp ->
919 let code dst = toOL [
922 DATA DF [ImmDouble d],
924 SETHI (HI (ImmCLbl lbl)) tmp,
925 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
927 returnNat (Any DoubleRep code)
929 -- The 6-word scratch area is immediately below the frame pointer.
930 -- Below that is the spill area.
931 getRegister (StScratchWord i)
934 code dst = unitOL (fpRelEA j dst)
936 returnNat (Any PtrRep code)
939 getRegister (StPrim primop [x]) -- unary PrimOps
941 IntNegOp -> trivialUCode (SUB False False g0) x
942 NotOp -> trivialUCode (XNOR False g0) x
944 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
945 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
947 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
948 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
950 OrdOp -> coerceIntCode IntRep x
953 Float2IntOp -> coerceFP2Int x
954 Int2FloatOp -> coerceInt2FP FloatRep x
955 Double2IntOp -> coerceFP2Int x
956 Int2DoubleOp -> coerceInt2FP DoubleRep x
960 fixed_x = if is_float_op -- promote to double
961 then StPrim Float2DoubleOp [x]
964 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
968 FloatExpOp -> (True, SLIT("exp"))
969 FloatLogOp -> (True, SLIT("log"))
970 FloatSqrtOp -> (True, SLIT("sqrt"))
972 FloatSinOp -> (True, SLIT("sin"))
973 FloatCosOp -> (True, SLIT("cos"))
974 FloatTanOp -> (True, SLIT("tan"))
976 FloatAsinOp -> (True, SLIT("asin"))
977 FloatAcosOp -> (True, SLIT("acos"))
978 FloatAtanOp -> (True, SLIT("atan"))
980 FloatSinhOp -> (True, SLIT("sinh"))
981 FloatCoshOp -> (True, SLIT("cosh"))
982 FloatTanhOp -> (True, SLIT("tanh"))
984 DoubleExpOp -> (False, SLIT("exp"))
985 DoubleLogOp -> (False, SLIT("log"))
986 DoubleSqrtOp -> (False, SLIT("sqrt"))
988 DoubleSinOp -> (False, SLIT("sin"))
989 DoubleCosOp -> (False, SLIT("cos"))
990 DoubleTanOp -> (False, SLIT("tan"))
992 DoubleAsinOp -> (False, SLIT("asin"))
993 DoubleAcosOp -> (False, SLIT("acos"))
994 DoubleAtanOp -> (False, SLIT("atan"))
996 DoubleSinhOp -> (False, SLIT("sinh"))
997 DoubleCoshOp -> (False, SLIT("cosh"))
998 DoubleTanhOp -> (False, SLIT("tanh"))
1001 -> pprPanic "getRegister(sparc,monadicprimop)"
1002 (pprStixTree (StPrim primop [x]))
1004 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1006 CharGtOp -> condIntReg GTT x y
1007 CharGeOp -> condIntReg GE x y
1008 CharEqOp -> condIntReg EQQ x y
1009 CharNeOp -> condIntReg NE x y
1010 CharLtOp -> condIntReg LTT x y
1011 CharLeOp -> condIntReg LE x y
1013 IntGtOp -> condIntReg GTT x y
1014 IntGeOp -> condIntReg GE x y
1015 IntEqOp -> condIntReg EQQ x y
1016 IntNeOp -> condIntReg NE x y
1017 IntLtOp -> condIntReg LTT x y
1018 IntLeOp -> condIntReg LE x y
1020 WordGtOp -> condIntReg GU x y
1021 WordGeOp -> condIntReg GEU x y
1022 WordEqOp -> condIntReg EQQ x y
1023 WordNeOp -> condIntReg NE x y
1024 WordLtOp -> condIntReg LU x y
1025 WordLeOp -> condIntReg LEU x y
1027 AddrGtOp -> condIntReg GU x y
1028 AddrGeOp -> condIntReg GEU x y
1029 AddrEqOp -> condIntReg EQQ x y
1030 AddrNeOp -> condIntReg NE x y
1031 AddrLtOp -> condIntReg LU x y
1032 AddrLeOp -> condIntReg LEU x y
1034 FloatGtOp -> condFltReg GTT x y
1035 FloatGeOp -> condFltReg GE x y
1036 FloatEqOp -> condFltReg EQQ x y
1037 FloatNeOp -> condFltReg NE x y
1038 FloatLtOp -> condFltReg LTT x y
1039 FloatLeOp -> condFltReg LE x y
1041 DoubleGtOp -> condFltReg GTT x y
1042 DoubleGeOp -> condFltReg GE x y
1043 DoubleEqOp -> condFltReg EQQ x y
1044 DoubleNeOp -> condFltReg NE x y
1045 DoubleLtOp -> condFltReg LTT x y
1046 DoubleLeOp -> condFltReg LE x y
1048 IntAddOp -> trivialCode (ADD False False) x y
1049 IntSubOp -> trivialCode (SUB False False) x y
1051 -- ToDo: teach about V8+ SPARC mul/div instructions
1052 IntMulOp -> imul_div SLIT(".umul") x y
1053 IntQuotOp -> imul_div SLIT(".div") x y
1054 IntRemOp -> imul_div SLIT(".rem") x y
1056 FloatAddOp -> trivialFCode FloatRep FADD x y
1057 FloatSubOp -> trivialFCode FloatRep FSUB x y
1058 FloatMulOp -> trivialFCode FloatRep FMUL x y
1059 FloatDivOp -> trivialFCode FloatRep FDIV x y
1061 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1062 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1063 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1064 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1066 AndOp -> trivialCode (AND False) x y
1067 OrOp -> trivialCode (OR False) x y
1068 XorOp -> trivialCode (XOR False) x y
1069 SllOp -> trivialCode SLL x y
1070 SrlOp -> trivialCode SRL x y
1072 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1073 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1074 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1076 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1077 [promote x, promote y])
1078 where promote x = StPrim Float2DoubleOp [x]
1079 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1083 -> pprPanic "getRegister(sparc,dyadic primop)"
1084 (pprStixTree (StPrim primop [x, y]))
1087 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1089 getRegister (StInd pk mem)
1090 = getAmode mem `thenNat` \ amode ->
1092 code = amodeCode amode
1093 src = amodeAddr amode
1094 size = primRepToSize pk
1095 code__2 dst = code `snocOL` LD size src dst
1097 returnNat (Any pk code__2)
1099 getRegister (StInt i)
1102 src = ImmInt (fromInteger i)
1103 code dst = unitOL (OR False g0 (RIImm src) dst)
1105 returnNat (Any IntRep code)
1111 SETHI (HI imm__2) dst,
1112 OR False dst (RIImm (LO imm__2)) dst]
1114 returnNat (Any PtrRep code)
1116 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1119 imm__2 = case imm of Just x -> x
1121 #endif {- sparc_TARGET_ARCH -}
1124 %************************************************************************
1126 \subsection{The @Amode@ type}
1128 %************************************************************************
1130 @Amode@s: Memory addressing modes passed up the tree.
1132 data Amode = Amode MachRegsAddr InstrBlock
1134 amodeAddr (Amode addr _) = addr
1135 amodeCode (Amode _ code) = code
1138 Now, given a tree (the argument to an StInd) that references memory,
1139 produce a suitable addressing mode.
1141 A Rule of the Game (tm) for Amodes: use of the addr bit must
1142 immediately follow use of the code part, since the code part puts
1143 values in registers which the addr then refers to. So you can't put
1144 anything in between, lest it overwrite some of those registers. If
1145 you need to do some other computation between the code part and use of
1146 the addr bit, first store the effective address from the amode in a
1147 temporary, then do the other computation, and then use the temporary:
1151 ... other computation ...
1155 getAmode :: StixTree -> NatM Amode
1157 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1159 #if alpha_TARGET_ARCH
1161 getAmode (StPrim IntSubOp [x, StInt i])
1162 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1163 getRegister x `thenNat` \ register ->
1165 code = registerCode register tmp
1166 reg = registerName register tmp
1167 off = ImmInt (-(fromInteger i))
1169 returnNat (Amode (AddrRegImm reg off) code)
1171 getAmode (StPrim IntAddOp [x, StInt i])
1172 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1173 getRegister x `thenNat` \ register ->
1175 code = registerCode register tmp
1176 reg = registerName register tmp
1177 off = ImmInt (fromInteger i)
1179 returnNat (Amode (AddrRegImm reg off) code)
1183 = returnNat (Amode (AddrImm imm__2) id)
1186 imm__2 = case imm of Just x -> x
1189 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1190 getRegister other `thenNat` \ register ->
1192 code = registerCode register tmp
1193 reg = registerName register tmp
1195 returnNat (Amode (AddrReg reg) code)
1197 #endif {- alpha_TARGET_ARCH -}
1198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1199 #if i386_TARGET_ARCH
1201 getAmode (StPrim IntSubOp [x, StInt i])
1202 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1203 getRegister x `thenNat` \ register ->
1205 code = registerCode register tmp
1206 reg = registerName register tmp
1207 off = ImmInt (-(fromInteger i))
1209 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1211 getAmode (StPrim IntAddOp [x, StInt i])
1213 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1216 imm__2 = case imm of Just x -> x
1218 getAmode (StPrim IntAddOp [x, StInt i])
1219 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1220 getRegister x `thenNat` \ register ->
1222 code = registerCode register tmp
1223 reg = registerName register tmp
1224 off = ImmInt (fromInteger i)
1226 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1228 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1229 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1230 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1231 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1232 getRegister x `thenNat` \ register1 ->
1233 getRegister y `thenNat` \ register2 ->
1235 code1 = registerCode register1 tmp1
1236 reg1 = registerName register1 tmp1
1237 code2 = registerCode register2 tmp2
1238 reg2 = registerName register2 tmp2
1239 code__2 = code1 `appOL` code2
1240 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1242 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1247 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1250 imm__2 = case imm of Just x -> x
1253 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1254 getRegister other `thenNat` \ register ->
1256 code = registerCode register tmp
1257 reg = registerName register tmp
1259 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1261 #endif {- i386_TARGET_ARCH -}
1262 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1263 #if sparc_TARGET_ARCH
1265 getAmode (StPrim IntSubOp [x, StInt i])
1267 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1268 getRegister x `thenNat` \ register ->
1270 code = registerCode register tmp
1271 reg = registerName register tmp
1272 off = ImmInt (-(fromInteger i))
1274 returnNat (Amode (AddrRegImm reg off) code)
1277 getAmode (StPrim IntAddOp [x, StInt i])
1279 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1280 getRegister x `thenNat` \ register ->
1282 code = registerCode register tmp
1283 reg = registerName register tmp
1284 off = ImmInt (fromInteger i)
1286 returnNat (Amode (AddrRegImm reg off) code)
1288 getAmode (StPrim IntAddOp [x, y])
1289 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1290 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1291 getRegister x `thenNat` \ register1 ->
1292 getRegister y `thenNat` \ register2 ->
1294 code1 = registerCode register1 tmp1
1295 reg1 = registerName register1 tmp1
1296 code2 = registerCode register2 tmp2
1297 reg2 = registerName register2 tmp2
1298 code__2 = code1 `appOL` code2
1300 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1304 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1306 code = unitOL (SETHI (HI imm__2) tmp)
1308 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1311 imm__2 = case imm of Just x -> x
1314 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1315 getRegister other `thenNat` \ register ->
1317 code = registerCode register tmp
1318 reg = registerName register tmp
1321 returnNat (Amode (AddrRegImm reg off) code)
1323 #endif {- sparc_TARGET_ARCH -}
1326 %************************************************************************
1328 \subsection{The @CondCode@ type}
1330 %************************************************************************
1332 Condition codes passed up the tree.
1334 data CondCode = CondCode Bool Cond InstrBlock
1336 condName (CondCode _ cond _) = cond
1337 condFloat (CondCode is_float _ _) = is_float
1338 condCode (CondCode _ _ code) = code
1341 Set up a condition code for a conditional branch.
1344 getCondCode :: StixTree -> NatM CondCode
1346 #if alpha_TARGET_ARCH
1347 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1348 #endif {- alpha_TARGET_ARCH -}
1349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1351 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1352 -- yes, they really do seem to want exactly the same!
1354 getCondCode (StPrim primop [x, y])
1356 CharGtOp -> condIntCode GTT x y
1357 CharGeOp -> condIntCode GE x y
1358 CharEqOp -> condIntCode EQQ x y
1359 CharNeOp -> condIntCode NE x y
1360 CharLtOp -> condIntCode LTT x y
1361 CharLeOp -> condIntCode LE x y
1363 IntGtOp -> condIntCode GTT x y
1364 IntGeOp -> condIntCode GE x y
1365 IntEqOp -> condIntCode EQQ x y
1366 IntNeOp -> condIntCode NE x y
1367 IntLtOp -> condIntCode LTT x y
1368 IntLeOp -> condIntCode LE x y
1370 WordGtOp -> condIntCode GU x y
1371 WordGeOp -> condIntCode GEU x y
1372 WordEqOp -> condIntCode EQQ x y
1373 WordNeOp -> condIntCode NE x y
1374 WordLtOp -> condIntCode LU x y
1375 WordLeOp -> condIntCode LEU x y
1377 AddrGtOp -> condIntCode GU x y
1378 AddrGeOp -> condIntCode GEU x y
1379 AddrEqOp -> condIntCode EQQ x y
1380 AddrNeOp -> condIntCode NE x y
1381 AddrLtOp -> condIntCode LU x y
1382 AddrLeOp -> condIntCode LEU x y
1384 FloatGtOp -> condFltCode GTT x y
1385 FloatGeOp -> condFltCode GE x y
1386 FloatEqOp -> condFltCode EQQ x y
1387 FloatNeOp -> condFltCode NE x y
1388 FloatLtOp -> condFltCode LTT x y
1389 FloatLeOp -> condFltCode LE x y
1391 DoubleGtOp -> condFltCode GTT x y
1392 DoubleGeOp -> condFltCode GE x y
1393 DoubleEqOp -> condFltCode EQQ x y
1394 DoubleNeOp -> condFltCode NE x y
1395 DoubleLtOp -> condFltCode LTT x y
1396 DoubleLeOp -> condFltCode LE x y
1398 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1403 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1404 passed back up the tree.
1407 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1409 #if alpha_TARGET_ARCH
1410 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1411 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1412 #endif {- alpha_TARGET_ARCH -}
1414 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1415 #if i386_TARGET_ARCH
1417 -- memory vs immediate
1418 condIntCode cond (StInd pk x) y
1420 = getAmode x `thenNat` \ amode ->
1422 code1 = amodeCode amode
1423 x__2 = amodeAddr amode
1424 sz = primRepToSize pk
1425 code__2 = code1 `snocOL`
1426 CMP sz (OpImm imm__2) (OpAddr x__2)
1428 returnNat (CondCode False cond code__2)
1431 imm__2 = case imm of Just x -> x
1434 condIntCode cond x (StInt 0)
1435 = getRegister x `thenNat` \ register1 ->
1436 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1438 code1 = registerCode register1 tmp1
1439 src1 = registerName register1 tmp1
1440 code__2 = code1 `snocOL`
1441 TEST L (OpReg src1) (OpReg src1)
1443 returnNat (CondCode False cond code__2)
1445 -- anything vs immediate
1446 condIntCode cond x y
1448 = getRegister x `thenNat` \ register1 ->
1449 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1451 code1 = registerCode register1 tmp1
1452 src1 = registerName register1 tmp1
1453 code__2 = code1 `snocOL`
1454 CMP L (OpImm imm__2) (OpReg src1)
1456 returnNat (CondCode False cond code__2)
1459 imm__2 = case imm of Just x -> x
1461 -- memory vs anything
1462 condIntCode cond (StInd pk x) y
1463 = getAmode x `thenNat` \ amode_x ->
1464 getRegister y `thenNat` \ reg_y ->
1465 getNewRegNCG IntRep `thenNat` \ tmp ->
1467 c_x = amodeCode amode_x
1468 am_x = amodeAddr amode_x
1469 c_y = registerCode reg_y tmp
1470 r_y = registerName reg_y tmp
1471 sz = primRepToSize pk
1473 -- optimisation: if there's no code for x, just an amode,
1474 -- use whatever reg y winds up in. Assumes that c_y doesn't
1475 -- clobber any regs in the amode am_x, which I'm not sure is
1476 -- justified. The otherwise clause makes the same assumption.
1477 code__2 | isNilOL c_x
1479 CMP sz (OpReg r_y) (OpAddr am_x)
1483 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1485 CMP sz (OpReg tmp) (OpAddr am_x)
1487 returnNat (CondCode False cond code__2)
1489 -- anything vs memory
1491 condIntCode cond y (StInd pk x)
1492 = getAmode x `thenNat` \ amode_x ->
1493 getRegister y `thenNat` \ reg_y ->
1494 getNewRegNCG IntRep `thenNat` \ tmp ->
1496 c_x = amodeCode amode_x
1497 am_x = amodeAddr amode_x
1498 c_y = registerCode reg_y tmp
1499 r_y = registerName reg_y tmp
1500 sz = primRepToSize pk
1501 -- same optimisation and nagging doubts as previous clause
1502 code__2 | isNilOL c_x
1504 CMP sz (OpAddr am_x) (OpReg r_y)
1508 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1510 CMP sz (OpAddr am_x) (OpReg tmp)
1512 returnNat (CondCode False cond code__2)
1514 -- anything vs anything
1515 condIntCode cond x y
1516 = getRegister x `thenNat` \ register1 ->
1517 getRegister y `thenNat` \ register2 ->
1518 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1519 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1521 code1 = registerCode register1 tmp1
1522 src1 = registerName register1 tmp1
1523 code2 = registerCode register2 tmp2
1524 src2 = registerName register2 tmp2
1525 code__2 = code1 `snocOL`
1526 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1528 CMP L (OpReg src2) (OpReg tmp1)
1530 returnNat (CondCode False cond code__2)
1533 condFltCode cond x y
1534 = getRegister x `thenNat` \ register1 ->
1535 getRegister y `thenNat` \ register2 ->
1536 getNewRegNCG (registerRep register1)
1538 getNewRegNCG (registerRep register2)
1540 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1542 pk1 = registerRep register1
1543 code1 = registerCode register1 tmp1
1544 src1 = registerName register1 tmp1
1546 pk2 = registerRep register2
1547 code2 = registerCode register2 tmp2
1548 src2 = registerName register2 tmp2
1550 code__2 | isAny register1
1551 = code1 `appOL` -- result in tmp1
1553 GCMP (primRepToSize pk1) tmp1 src2
1557 GMOV src1 tmp1 `appOL`
1559 GCMP (primRepToSize pk1) tmp1 src2
1561 {- On the 486, the flags set by FP compare are the unsigned ones!
1562 (This looks like a HACK to me. WDP 96/03)
1564 fix_FP_cond :: Cond -> Cond
1566 fix_FP_cond GE = GEU
1567 fix_FP_cond GTT = GU
1568 fix_FP_cond LTT = LU
1569 fix_FP_cond LE = LEU
1570 fix_FP_cond any = any
1572 returnNat (CondCode True (fix_FP_cond cond) code__2)
1576 #endif {- i386_TARGET_ARCH -}
1577 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1578 #if sparc_TARGET_ARCH
1580 condIntCode cond x (StInt y)
1582 = getRegister x `thenNat` \ register ->
1583 getNewRegNCG IntRep `thenNat` \ tmp ->
1585 code = registerCode register tmp
1586 src1 = registerName register tmp
1587 src2 = ImmInt (fromInteger y)
1588 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1590 returnNat (CondCode False cond code__2)
1592 condIntCode cond x y
1593 = getRegister x `thenNat` \ register1 ->
1594 getRegister y `thenNat` \ register2 ->
1595 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1596 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1598 code1 = registerCode register1 tmp1
1599 src1 = registerName register1 tmp1
1600 code2 = registerCode register2 tmp2
1601 src2 = registerName register2 tmp2
1602 code__2 = code1 `appOL` code2 `snocOL`
1603 SUB False True src1 (RIReg src2) g0
1605 returnNat (CondCode False cond code__2)
1608 condFltCode cond x y
1609 = getRegister x `thenNat` \ register1 ->
1610 getRegister y `thenNat` \ register2 ->
1611 getNewRegNCG (registerRep register1)
1613 getNewRegNCG (registerRep register2)
1615 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1617 promote x = FxTOy F DF x tmp
1619 pk1 = registerRep register1
1620 code1 = registerCode register1 tmp1
1621 src1 = registerName register1 tmp1
1623 pk2 = registerRep register2
1624 code2 = registerCode register2 tmp2
1625 src2 = registerName register2 tmp2
1629 code1 `appOL` code2 `snocOL`
1630 FCMP True (primRepToSize pk1) src1 src2
1631 else if pk1 == FloatRep then
1632 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1633 FCMP True DF tmp src2
1635 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1636 FCMP True DF src1 tmp
1638 returnNat (CondCode True cond code__2)
1640 #endif {- sparc_TARGET_ARCH -}
1643 %************************************************************************
1645 \subsection{Generating assignments}
1647 %************************************************************************
1649 Assignments are really at the heart of the whole code generation
1650 business. Almost all top-level nodes of any real importance are
1651 assignments, which correspond to loads, stores, or register transfers.
1652 If we're really lucky, some of the register transfers will go away,
1653 because we can use the destination register to complete the code
1654 generation for the right hand side. This only fails when the right
1655 hand side is forced into a fixed register (e.g. the result of a call).
1658 assignIntCode, assignFltCode
1659 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1661 #if alpha_TARGET_ARCH
1663 assignIntCode pk (StInd _ dst) src
1664 = getNewRegNCG IntRep `thenNat` \ tmp ->
1665 getAmode dst `thenNat` \ amode ->
1666 getRegister src `thenNat` \ register ->
1668 code1 = amodeCode amode []
1669 dst__2 = amodeAddr amode
1670 code2 = registerCode register tmp []
1671 src__2 = registerName register tmp
1672 sz = primRepToSize pk
1673 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1677 assignIntCode pk dst src
1678 = getRegister dst `thenNat` \ register1 ->
1679 getRegister src `thenNat` \ register2 ->
1681 dst__2 = registerName register1 zeroh
1682 code = registerCode register2 dst__2
1683 src__2 = registerName register2 dst__2
1684 code__2 = if isFixed register2
1685 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1690 #endif {- alpha_TARGET_ARCH -}
1691 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1692 #if i386_TARGET_ARCH
1694 -- Destination of an assignment can only be reg or mem.
1695 -- This is the mem case.
1696 assignIntCode pk (StInd _ dst) src
1697 = getAmode dst `thenNat` \ amode ->
1698 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1699 getNewRegNCG PtrRep `thenNat` \ tmp ->
1701 -- In general, if the address computation for dst may require
1702 -- some insns preceding the addressing mode itself. So there's
1703 -- no guarantee that the code for dst and the code for src won't
1704 -- write the same register. This means either the address or
1705 -- the value needs to be copied into a temporary. We detect the
1706 -- common case where the amode has no code, and elide the copy.
1707 codea = amodeCode amode
1708 dst__a = amodeAddr amode
1710 code | isNilOL codea
1712 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1716 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1718 MOV (primRepToSize pk) opsrc
1719 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1725 -> NatM (InstrBlock,Operand) -- code, operator
1729 = returnNat (nilOL, OpImm imm_op)
1732 imm_op = case imm of Just x -> x
1735 = getRegister op `thenNat` \ register ->
1736 getNewRegNCG (registerRep register)
1738 let code = registerCode register tmp
1739 reg = registerName register tmp
1741 returnNat (code, OpReg reg)
1743 -- Assign; dst is a reg, rhs is mem
1744 assignIntCode pk dst (StInd pks src)
1745 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1746 getAmode src `thenNat` \ amode ->
1747 getRegister dst `thenNat` \ reg_dst ->
1749 c_addr = amodeCode amode
1750 am_addr = amodeAddr amode
1752 c_dst = registerCode reg_dst tmp -- should be empty
1753 r_dst = registerName reg_dst tmp
1754 szs = primRepToSize pks
1755 opc = case szs of L -> MOV L ; B -> MOVZxL B
1757 code | isNilOL c_dst
1759 opc (OpAddr am_addr) (OpReg r_dst)
1761 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1765 -- dst is a reg, but src could be anything
1766 assignIntCode pk dst src
1767 = getRegister dst `thenNat` \ registerd ->
1768 getRegister src `thenNat` \ registers ->
1769 getNewRegNCG IntRep `thenNat` \ tmp ->
1771 r_dst = registerName registerd tmp
1772 c_dst = registerCode registerd tmp -- should be empty
1773 r_src = registerName registers r_dst
1774 c_src = registerCode registers r_dst
1776 code | isNilOL c_dst
1778 MOV L (OpReg r_src) (OpReg r_dst)
1780 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1784 #endif {- i386_TARGET_ARCH -}
1785 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1786 #if sparc_TARGET_ARCH
1788 assignIntCode pk (StInd _ dst) src
1789 = getNewRegNCG IntRep `thenNat` \ tmp ->
1790 getAmode dst `thenNat` \ amode ->
1791 getRegister src `thenNat` \ register ->
1793 code1 = amodeCode amode
1794 dst__2 = amodeAddr amode
1795 code2 = registerCode register tmp
1796 src__2 = registerName register tmp
1797 sz = primRepToSize pk
1798 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1802 assignIntCode pk dst src
1803 = getRegister dst `thenNat` \ register1 ->
1804 getRegister src `thenNat` \ register2 ->
1806 dst__2 = registerName register1 g0
1807 code = registerCode register2 dst__2
1808 src__2 = registerName register2 dst__2
1809 code__2 = if isFixed register2
1810 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1815 #endif {- sparc_TARGET_ARCH -}
1818 % --------------------------------
1819 Floating-point assignments:
1820 % --------------------------------
1822 #if alpha_TARGET_ARCH
1824 assignFltCode pk (StInd _ dst) src
1825 = getNewRegNCG pk `thenNat` \ tmp ->
1826 getAmode dst `thenNat` \ amode ->
1827 getRegister src `thenNat` \ register ->
1829 code1 = amodeCode amode []
1830 dst__2 = amodeAddr amode
1831 code2 = registerCode register tmp []
1832 src__2 = registerName register tmp
1833 sz = primRepToSize pk
1834 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1838 assignFltCode pk dst src
1839 = getRegister dst `thenNat` \ register1 ->
1840 getRegister src `thenNat` \ register2 ->
1842 dst__2 = registerName register1 zeroh
1843 code = registerCode register2 dst__2
1844 src__2 = registerName register2 dst__2
1845 code__2 = if isFixed register2
1846 then code . mkSeqInstr (FMOV src__2 dst__2)
1851 #endif {- alpha_TARGET_ARCH -}
1852 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1853 #if i386_TARGET_ARCH
1856 assignFltCode pk (StInd pk_dst addr) src
1858 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1860 = getRegister src `thenNat` \ reg_src ->
1861 getRegister addr `thenNat` \ reg_addr ->
1862 getNewRegNCG pk `thenNat` \ tmp_src ->
1863 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1864 let r_src = registerName reg_src tmp_src
1865 c_src = registerCode reg_src tmp_src
1866 r_addr = registerName reg_addr tmp_addr
1867 c_addr = registerCode reg_addr tmp_addr
1868 sz = primRepToSize pk
1870 code = c_src `appOL`
1871 -- no need to preserve r_src across the addr computation,
1872 -- since r_src must be a float reg
1873 -- whilst r_addr is an int reg
1876 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1880 -- dst must be a (FP) register
1881 assignFltCode pk dst src
1882 = getRegister dst `thenNat` \ reg_dst ->
1883 getRegister src `thenNat` \ reg_src ->
1884 getNewRegNCG pk `thenNat` \ tmp ->
1886 r_dst = registerName reg_dst tmp
1887 c_dst = registerCode reg_dst tmp -- should be empty
1889 r_src = registerName reg_src r_dst
1890 c_src = registerCode reg_src r_dst
1892 code | isNilOL c_dst
1893 = if isFixed reg_src
1894 then c_src `snocOL` GMOV r_src r_dst
1897 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1903 #endif {- i386_TARGET_ARCH -}
1904 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1905 #if sparc_TARGET_ARCH
1907 assignFltCode pk (StInd _ dst) src
1908 = getNewRegNCG pk `thenNat` \ tmp1 ->
1909 getAmode dst `thenNat` \ amode ->
1910 getRegister src `thenNat` \ register ->
1912 sz = primRepToSize pk
1913 dst__2 = amodeAddr amode
1915 code1 = amodeCode amode
1916 code2 = registerCode register tmp1
1918 src__2 = registerName register tmp1
1919 pk__2 = registerRep register
1920 sz__2 = primRepToSize pk__2
1922 code__2 = code1 `appOL` code2 `appOL`
1924 then unitOL (ST sz src__2 dst__2)
1925 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1929 assignFltCode pk dst src
1930 = getRegister dst `thenNat` \ register1 ->
1931 getRegister src `thenNat` \ register2 ->
1933 pk__2 = registerRep register2
1934 sz__2 = primRepToSize pk__2
1936 getNewRegNCG pk__2 `thenNat` \ tmp ->
1938 sz = primRepToSize pk
1939 dst__2 = registerName register1 g0 -- must be Fixed
1942 reg__2 = if pk /= pk__2 then tmp else dst__2
1944 code = registerCode register2 reg__2
1946 src__2 = registerName register2 reg__2
1950 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1951 else if isFixed register2 then
1952 code `snocOL` FMOV sz src__2 dst__2
1958 #endif {- sparc_TARGET_ARCH -}
1961 %************************************************************************
1963 \subsection{Generating an unconditional branch}
1965 %************************************************************************
1967 We accept two types of targets: an immediate CLabel or a tree that
1968 gets evaluated into a register. Any CLabels which are AsmTemporaries
1969 are assumed to be in the local block of code, close enough for a
1970 branch instruction. Other CLabels are assumed to be far away.
1972 (If applicable) Do not fill the delay slots here; you will confuse the
1976 genJump :: StixTree{-the branch target-} -> NatM InstrBlock
1978 #if alpha_TARGET_ARCH
1980 genJump (StCLbl lbl)
1981 | isAsmTemp lbl = returnInstr (BR target)
1982 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1984 target = ImmCLbl lbl
1987 = getRegister tree `thenNat` \ register ->
1988 getNewRegNCG PtrRep `thenNat` \ tmp ->
1990 dst = registerName register pv
1991 code = registerCode register pv
1992 target = registerName register pv
1994 if isFixed register then
1995 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1997 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1999 #endif {- alpha_TARGET_ARCH -}
2000 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2001 #if i386_TARGET_ARCH
2003 genJump (StInd pk mem)
2004 = getAmode mem `thenNat` \ amode ->
2006 code = amodeCode amode
2007 target = amodeAddr amode
2009 returnNat (code `snocOL` JMP (OpAddr target))
2013 = returnNat (unitOL (JMP (OpImm target)))
2016 = getRegister tree `thenNat` \ register ->
2017 getNewRegNCG PtrRep `thenNat` \ tmp ->
2019 code = registerCode register tmp
2020 target = registerName register tmp
2022 returnNat (code `snocOL` JMP (OpReg target))
2025 target = case imm of Just x -> x
2027 #endif {- i386_TARGET_ARCH -}
2028 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2029 #if sparc_TARGET_ARCH
2031 genJump (StCLbl lbl)
2032 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2033 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2035 target = ImmCLbl lbl
2038 = getRegister tree `thenNat` \ register ->
2039 getNewRegNCG PtrRep `thenNat` \ tmp ->
2041 code = registerCode register tmp
2042 target = registerName register tmp
2044 returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
2046 #endif {- sparc_TARGET_ARCH -}
2049 %************************************************************************
2051 \subsection{Conditional jumps}
2053 %************************************************************************
2055 Conditional jumps are always to local labels, so we can use branch
2056 instructions. We peek at the arguments to decide what kind of
2059 ALPHA: For comparisons with 0, we're laughing, because we can just do
2060 the desired conditional branch.
2062 I386: First, we have to ensure that the condition
2063 codes are set according to the supplied comparison operation.
2065 SPARC: First, we have to ensure that the condition codes are set
2066 according to the supplied comparison operation. We generate slightly
2067 different code for floating point comparisons, because a floating
2068 point operation cannot directly precede a @BF@. We assume the worst
2069 and fill that slot with a @NOP@.
2071 SPARC: Do not fill the delay slots here; you will confuse the register
2076 :: CLabel -- the branch target
2077 -> StixTree -- the condition on which to branch
2080 #if alpha_TARGET_ARCH
2082 genCondJump lbl (StPrim op [x, StInt 0])
2083 = getRegister x `thenNat` \ register ->
2084 getNewRegNCG (registerRep register)
2087 code = registerCode register tmp
2088 value = registerName register tmp
2089 pk = registerRep register
2090 target = ImmCLbl lbl
2092 returnSeq code [BI (cmpOp op) value target]
2094 cmpOp CharGtOp = GTT
2096 cmpOp CharEqOp = EQQ
2098 cmpOp CharLtOp = LTT
2107 cmpOp WordGeOp = ALWAYS
2108 cmpOp WordEqOp = EQQ
2110 cmpOp WordLtOp = NEVER
2111 cmpOp WordLeOp = EQQ
2113 cmpOp AddrGeOp = ALWAYS
2114 cmpOp AddrEqOp = EQQ
2116 cmpOp AddrLtOp = NEVER
2117 cmpOp AddrLeOp = EQQ
2119 genCondJump lbl (StPrim op [x, StDouble 0.0])
2120 = getRegister x `thenNat` \ register ->
2121 getNewRegNCG (registerRep register)
2124 code = registerCode register tmp
2125 value = registerName register tmp
2126 pk = registerRep register
2127 target = ImmCLbl lbl
2129 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2131 cmpOp FloatGtOp = GTT
2132 cmpOp FloatGeOp = GE
2133 cmpOp FloatEqOp = EQQ
2134 cmpOp FloatNeOp = NE
2135 cmpOp FloatLtOp = LTT
2136 cmpOp FloatLeOp = LE
2137 cmpOp DoubleGtOp = GTT
2138 cmpOp DoubleGeOp = GE
2139 cmpOp DoubleEqOp = EQQ
2140 cmpOp DoubleNeOp = NE
2141 cmpOp DoubleLtOp = LTT
2142 cmpOp DoubleLeOp = LE
2144 genCondJump lbl (StPrim op [x, y])
2146 = trivialFCode pr instr x y `thenNat` \ register ->
2147 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2149 code = registerCode register tmp
2150 result = registerName register tmp
2151 target = ImmCLbl lbl
2153 returnNat (code . mkSeqInstr (BF cond result target))
2155 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2157 fltCmpOp op = case op of
2171 (instr, cond) = case op of
2172 FloatGtOp -> (FCMP TF LE, EQQ)
2173 FloatGeOp -> (FCMP TF LTT, EQQ)
2174 FloatEqOp -> (FCMP TF EQQ, NE)
2175 FloatNeOp -> (FCMP TF EQQ, EQQ)
2176 FloatLtOp -> (FCMP TF LTT, NE)
2177 FloatLeOp -> (FCMP TF LE, NE)
2178 DoubleGtOp -> (FCMP TF LE, EQQ)
2179 DoubleGeOp -> (FCMP TF LTT, EQQ)
2180 DoubleEqOp -> (FCMP TF EQQ, NE)
2181 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2182 DoubleLtOp -> (FCMP TF LTT, NE)
2183 DoubleLeOp -> (FCMP TF LE, NE)
2185 genCondJump lbl (StPrim op [x, y])
2186 = trivialCode instr x y `thenNat` \ register ->
2187 getNewRegNCG IntRep `thenNat` \ tmp ->
2189 code = registerCode register tmp
2190 result = registerName register tmp
2191 target = ImmCLbl lbl
2193 returnNat (code . mkSeqInstr (BI cond result target))
2195 (instr, cond) = case op of
2196 CharGtOp -> (CMP LE, EQQ)
2197 CharGeOp -> (CMP LTT, EQQ)
2198 CharEqOp -> (CMP EQQ, NE)
2199 CharNeOp -> (CMP EQQ, EQQ)
2200 CharLtOp -> (CMP LTT, NE)
2201 CharLeOp -> (CMP LE, NE)
2202 IntGtOp -> (CMP LE, EQQ)
2203 IntGeOp -> (CMP LTT, EQQ)
2204 IntEqOp -> (CMP EQQ, NE)
2205 IntNeOp -> (CMP EQQ, EQQ)
2206 IntLtOp -> (CMP LTT, NE)
2207 IntLeOp -> (CMP LE, NE)
2208 WordGtOp -> (CMP ULE, EQQ)
2209 WordGeOp -> (CMP ULT, EQQ)
2210 WordEqOp -> (CMP EQQ, NE)
2211 WordNeOp -> (CMP EQQ, EQQ)
2212 WordLtOp -> (CMP ULT, NE)
2213 WordLeOp -> (CMP ULE, NE)
2214 AddrGtOp -> (CMP ULE, EQQ)
2215 AddrGeOp -> (CMP ULT, EQQ)
2216 AddrEqOp -> (CMP EQQ, NE)
2217 AddrNeOp -> (CMP EQQ, EQQ)
2218 AddrLtOp -> (CMP ULT, NE)
2219 AddrLeOp -> (CMP ULE, NE)
2221 #endif {- alpha_TARGET_ARCH -}
2222 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2223 #if i386_TARGET_ARCH
2225 genCondJump lbl bool
2226 = getCondCode bool `thenNat` \ condition ->
2228 code = condCode condition
2229 cond = condName condition
2230 target = ImmCLbl lbl
2232 returnNat (code `snocOL` JXX cond lbl)
2234 #endif {- i386_TARGET_ARCH -}
2235 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2236 #if sparc_TARGET_ARCH
2238 genCondJump lbl bool
2239 = getCondCode bool `thenNat` \ condition ->
2241 code = condCode condition
2242 cond = condName condition
2243 target = ImmCLbl lbl
2248 if condFloat condition
2249 then [NOP, BF cond False target, NOP]
2250 else [BI cond False target, NOP]
2254 #endif {- sparc_TARGET_ARCH -}
2257 %************************************************************************
2259 \subsection{Generating C calls}
2261 %************************************************************************
2263 Now the biggest nightmare---calls. Most of the nastiness is buried in
2264 @get_arg@, which moves the arguments to the correct registers/stack
2265 locations. Apart from that, the code is easy.
2267 (If applicable) Do not fill the delay slots here; you will confuse the
2272 :: FAST_STRING -- function to call
2274 -> PrimRep -- type of the result
2275 -> [StixTree] -- arguments (of mixed type)
2278 #if alpha_TARGET_ARCH
2280 genCCall fn cconv kind args
2281 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2282 `thenNat` \ ((unused,_), argCode) ->
2284 nRegs = length allArgRegs - length unused
2285 code = asmSeqThen (map ($ []) argCode)
2288 LDA pv (AddrImm (ImmLab (ptext fn))),
2289 JSR ra (AddrReg pv) nRegs,
2290 LDGP gp (AddrReg ra)]
2292 ------------------------
2293 {- Try to get a value into a specific register (or registers) for
2294 a call. The first 6 arguments go into the appropriate
2295 argument register (separate registers for integer and floating
2296 point arguments, but used in lock-step), and the remaining
2297 arguments are dumped to the stack, beginning at 0(sp). Our
2298 first argument is a pair of the list of remaining argument
2299 registers to be assigned for this call and the next stack
2300 offset to use for overflowing arguments. This way,
2301 @get_Arg@ can be applied to all of a call's arguments using
2305 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2306 -> StixTree -- Current argument
2307 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2309 -- We have to use up all of our argument registers first...
2311 get_arg ((iDst,fDst):dsts, offset) arg
2312 = getRegister arg `thenNat` \ register ->
2314 reg = if isFloatingRep pk then fDst else iDst
2315 code = registerCode register reg
2316 src = registerName register reg
2317 pk = registerRep register
2320 if isFloatingRep pk then
2321 ((dsts, offset), if isFixed register then
2322 code . mkSeqInstr (FMOV src fDst)
2325 ((dsts, offset), if isFixed register then
2326 code . mkSeqInstr (OR src (RIReg src) iDst)
2329 -- Once we have run out of argument registers, we move to the
2332 get_arg ([], offset) arg
2333 = getRegister arg `thenNat` \ register ->
2334 getNewRegNCG (registerRep register)
2337 code = registerCode register tmp
2338 src = registerName register tmp
2339 pk = registerRep register
2340 sz = primRepToSize pk
2342 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2344 #endif {- alpha_TARGET_ARCH -}
2345 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2346 #if i386_TARGET_ARCH
2348 genCCall fn cconv kind [StInt i]
2349 | fn == SLIT ("PerformGC_wrapper")
2351 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2352 CALL (ImmLit (ptext (if underscorePrefix
2353 then (SLIT ("_PerformGC_wrapper"))
2354 else (SLIT ("PerformGC_wrapper")))))
2360 genCCall fn cconv kind args
2361 = mapNat get_call_arg
2362 (reverse args) `thenNat` \ sizes_n_codes ->
2363 getDeltaNat `thenNat` \ delta ->
2364 let (sizes, codes) = unzip sizes_n_codes
2365 tot_arg_size = sum sizes
2366 code2 = concatOL codes
2369 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2370 DELTA (delta + tot_arg_size)
2373 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2374 returnNat (code2 `appOL` call)
2377 -- function names that begin with '.' are assumed to be special
2378 -- internally generated names like '.mul,' which don't get an
2379 -- underscore prefix
2380 -- ToDo:needed (WDP 96/03) ???
2381 fn__2 = case (_HEAD_ fn) of
2382 '.' -> ImmLit (ptext fn)
2383 _ -> ImmLab False (ptext fn)
2390 get_call_arg :: StixTree{-current argument-}
2391 -> NatM (Int, InstrBlock) -- argsz, code
2394 = get_op arg `thenNat` \ (code, reg, sz) ->
2395 getDeltaNat `thenNat` \ delta ->
2396 arg_size sz `bind` \ size ->
2397 setDeltaNat (delta-size) `thenNat` \ _ ->
2398 if (case sz of DF -> True; F -> True; _ -> False)
2399 then returnNat (size,
2401 toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
2403 GST DF reg (AddrBaseIndex (Just esp)
2407 else returnNat (size,
2409 PUSH L (OpReg reg) `snocOL`
2415 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2418 = getRegister op `thenNat` \ register ->
2419 getNewRegNCG (registerRep register)
2422 code = registerCode register tmp
2423 reg = registerName register tmp
2424 pk = registerRep register
2425 sz = primRepToSize pk
2427 returnNat (code, reg, sz)
2429 #endif {- i386_TARGET_ARCH -}
2430 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2431 #if sparc_TARGET_ARCH
2432 genCCall fn cconv kind args
2433 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2434 `thenNat` \ ((unused,_), argCode) ->
2437 nRegs = length allArgRegs - length unused
2438 call = unitOL (CALL fn__2 nRegs False)
2439 code = concatOL argCode
2441 -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args
2442 (move_sp_down, move_sp_up)
2443 = let nn = length args - 3
2446 else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn)))
2448 returnNat (move_sp_down `appOL`
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) ???
2458 fn__2 = case (_HEAD_ fn) of
2459 '.' -> ImmLit (ptext fn)
2460 _ -> ImmLab False (ptext fn)
2462 ------------------------------------
2463 {- Try to get a value into a specific register (or registers) for
2464 a call. The SPARC calling convention is an absolute
2465 nightmare. The first 6x32 bits of arguments are mapped into
2466 %o0 through %o5, and the remaining arguments are dumped to the
2467 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2468 first argument is a pair of the list of remaining argument
2469 registers to be assigned for this call and the next stack
2470 offset to use for overflowing arguments. This way,
2471 @get_arg@ can be applied to all of a call's arguments using
2474 If we have to put args on the stack, move %o6==%sp down by
2475 8 x the number of args, to ensure there's enough space.
2478 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2479 -> StixTree -- Current argument
2480 -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2482 -- We have to use up all of our argument registers first...
2484 get_arg (dst:dsts, offset) arg
2485 = getRegister arg `thenNat` \ register ->
2486 getNewRegNCG (registerRep register)
2489 reg = if isFloatingRep pk then tmp else dst
2490 code = registerCode register reg
2491 src = registerName register reg
2492 pk = registerRep register
2498 [] -> ( ([], offset + 1),
2500 -- put the second part in the right stack
2501 -- and load the first part into %o5
2502 FMOV DF src f0 `snocOL`
2503 ST F f0 (spRel offset) `snocOL`
2504 LD W (spRel offset) dst `snocOL`
2505 ST F (fPair f0) (spRel offset)
2508 -> ( (dsts__2, offset),
2510 FMOV DF src f0 `snocOL`
2511 ST F f0 (spRel 16) `snocOL`
2512 LD W (spRel 16) dst `snocOL`
2513 ST F (fPair f0) (spRel 16) `snocOL`
2514 LD W (spRel 16) dst__2
2517 -> ( (dsts, offset),
2519 ST F src (spRel 16) `snocOL`
2522 _ -> ( (dsts, offset),
2524 then code `snocOL` OR False g0 (RIReg src) dst
2528 -- Once we have run out of argument registers, we move to the
2531 get_arg ([], offset) arg
2532 = getRegister arg `thenNat` \ register ->
2533 getNewRegNCG (registerRep register)
2536 code = registerCode register tmp
2537 src = registerName register tmp
2538 pk = registerRep register
2539 sz = primRepToSize pk
2540 words = if pk == DoubleRep then 2 else 1
2542 returnNat ( ([], offset + words),
2543 code `snocOL` ST sz src (spRel offset) )
2545 #endif {- sparc_TARGET_ARCH -}
2548 %************************************************************************
2550 \subsection{Support bits}
2552 %************************************************************************
2554 %************************************************************************
2556 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2558 %************************************************************************
2560 Turn those condition codes into integers now (when they appear on
2561 the right hand side of an assignment).
2563 (If applicable) Do not fill the delay slots here; you will confuse the
2567 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2569 #if alpha_TARGET_ARCH
2570 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2571 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2572 #endif {- alpha_TARGET_ARCH -}
2574 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2575 #if i386_TARGET_ARCH
2578 = condIntCode cond x y `thenNat` \ condition ->
2579 getNewRegNCG IntRep `thenNat` \ tmp ->
2581 code = condCode condition
2582 cond = condName condition
2583 code__2 dst = code `appOL` toOL [
2584 SETCC cond (OpReg tmp),
2585 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2586 MOV L (OpReg tmp) (OpReg dst)]
2588 returnNat (Any IntRep code__2)
2591 = getNatLabelNCG `thenNat` \ lbl1 ->
2592 getNatLabelNCG `thenNat` \ lbl2 ->
2593 condFltCode cond x y `thenNat` \ condition ->
2595 code = condCode condition
2596 cond = condName condition
2597 code__2 dst = code `appOL` toOL [
2599 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2602 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2605 returnNat (Any IntRep code__2)
2607 #endif {- i386_TARGET_ARCH -}
2608 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2609 #if sparc_TARGET_ARCH
2611 condIntReg EQQ x (StInt 0)
2612 = getRegister x `thenNat` \ register ->
2613 getNewRegNCG IntRep `thenNat` \ tmp ->
2615 code = registerCode register tmp
2616 src = registerName register tmp
2617 code__2 dst = code `appOL` toOL [
2618 SUB False True g0 (RIReg src) g0,
2619 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2621 returnNat (Any IntRep code__2)
2624 = getRegister x `thenNat` \ register1 ->
2625 getRegister y `thenNat` \ register2 ->
2626 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2627 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2629 code1 = registerCode register1 tmp1
2630 src1 = registerName register1 tmp1
2631 code2 = registerCode register2 tmp2
2632 src2 = registerName register2 tmp2
2633 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2634 XOR False src1 (RIReg src2) dst,
2635 SUB False True g0 (RIReg dst) g0,
2636 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2638 returnNat (Any IntRep code__2)
2640 condIntReg NE x (StInt 0)
2641 = getRegister x `thenNat` \ register ->
2642 getNewRegNCG IntRep `thenNat` \ tmp ->
2644 code = registerCode register tmp
2645 src = registerName register tmp
2646 code__2 dst = code `appOL` toOL [
2647 SUB False True g0 (RIReg src) g0,
2648 ADD True False g0 (RIImm (ImmInt 0)) dst]
2650 returnNat (Any IntRep code__2)
2653 = getRegister x `thenNat` \ register1 ->
2654 getRegister y `thenNat` \ register2 ->
2655 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2656 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2658 code1 = registerCode register1 tmp1
2659 src1 = registerName register1 tmp1
2660 code2 = registerCode register2 tmp2
2661 src2 = registerName register2 tmp2
2662 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2663 XOR False src1 (RIReg src2) dst,
2664 SUB False True g0 (RIReg dst) g0,
2665 ADD True False g0 (RIImm (ImmInt 0)) dst]
2667 returnNat (Any IntRep code__2)
2670 = getNatLabelNCG `thenNat` \ lbl1 ->
2671 getNatLabelNCG `thenNat` \ lbl2 ->
2672 condIntCode cond x y `thenNat` \ condition ->
2674 code = condCode condition
2675 cond = condName condition
2676 code__2 dst = code `appOL` toOL [
2677 BI cond False (ImmCLbl lbl1), NOP,
2678 OR False g0 (RIImm (ImmInt 0)) dst,
2679 BI ALWAYS False (ImmCLbl lbl2), NOP,
2681 OR False g0 (RIImm (ImmInt 1)) dst,
2684 returnNat (Any IntRep code__2)
2687 = getNatLabelNCG `thenNat` \ lbl1 ->
2688 getNatLabelNCG `thenNat` \ lbl2 ->
2689 condFltCode cond x y `thenNat` \ condition ->
2691 code = condCode condition
2692 cond = condName condition
2693 code__2 dst = code `appOL` toOL [
2695 BF cond False (ImmCLbl lbl1), NOP,
2696 OR False g0 (RIImm (ImmInt 0)) dst,
2697 BI ALWAYS False (ImmCLbl lbl2), NOP,
2699 OR False g0 (RIImm (ImmInt 1)) dst,
2702 returnNat (Any IntRep code__2)
2704 #endif {- sparc_TARGET_ARCH -}
2707 %************************************************************************
2709 \subsubsection{@trivial*Code@: deal with trivial instructions}
2711 %************************************************************************
2713 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2714 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2715 for constants on the right hand side, because that's where the generic
2716 optimizer will have put them.
2718 Similarly, for unary instructions, we don't have to worry about
2719 matching an StInt as the argument, because genericOpt will already
2720 have handled the constant-folding.
2724 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2725 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2726 -> Maybe (Operand -> Operand -> Instr)
2727 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2729 -> StixTree -> StixTree -- the two arguments
2734 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2735 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2736 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2738 -> StixTree -> StixTree -- the two arguments
2742 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2743 ,IF_ARCH_i386 ((Operand -> Instr)
2744 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2746 -> StixTree -- the one argument
2751 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2752 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2753 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2755 -> StixTree -- the one argument
2758 #if alpha_TARGET_ARCH
2760 trivialCode instr x (StInt y)
2762 = getRegister x `thenNat` \ register ->
2763 getNewRegNCG IntRep `thenNat` \ tmp ->
2765 code = registerCode register tmp
2766 src1 = registerName register tmp
2767 src2 = ImmInt (fromInteger y)
2768 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2770 returnNat (Any IntRep code__2)
2772 trivialCode instr x y
2773 = getRegister x `thenNat` \ register1 ->
2774 getRegister y `thenNat` \ register2 ->
2775 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2776 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2778 code1 = registerCode register1 tmp1 []
2779 src1 = registerName register1 tmp1
2780 code2 = registerCode register2 tmp2 []
2781 src2 = registerName register2 tmp2
2782 code__2 dst = asmSeqThen [code1, code2] .
2783 mkSeqInstr (instr src1 (RIReg src2) dst)
2785 returnNat (Any IntRep code__2)
2788 trivialUCode instr x
2789 = getRegister x `thenNat` \ register ->
2790 getNewRegNCG IntRep `thenNat` \ tmp ->
2792 code = registerCode register tmp
2793 src = registerName register tmp
2794 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2796 returnNat (Any IntRep code__2)
2799 trivialFCode _ instr x y
2800 = getRegister x `thenNat` \ register1 ->
2801 getRegister y `thenNat` \ register2 ->
2802 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2803 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2805 code1 = registerCode register1 tmp1
2806 src1 = registerName register1 tmp1
2808 code2 = registerCode register2 tmp2
2809 src2 = registerName register2 tmp2
2811 code__2 dst = asmSeqThen [code1 [], code2 []] .
2812 mkSeqInstr (instr src1 src2 dst)
2814 returnNat (Any DoubleRep code__2)
2816 trivialUFCode _ instr x
2817 = getRegister x `thenNat` \ register ->
2818 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2820 code = registerCode register tmp
2821 src = registerName register tmp
2822 code__2 dst = code . mkSeqInstr (instr src dst)
2824 returnNat (Any DoubleRep code__2)
2826 #endif {- alpha_TARGET_ARCH -}
2827 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2828 #if i386_TARGET_ARCH
2830 The Rules of the Game are:
2832 * You cannot assume anything about the destination register dst;
2833 it may be anything, including a fixed reg.
2835 * You may compute an operand into a fixed reg, but you may not
2836 subsequently change the contents of that fixed reg. If you
2837 want to do so, first copy the value either to a temporary
2838 or into dst. You are free to modify dst even if it happens
2839 to be a fixed reg -- that's not your problem.
2841 * You cannot assume that a fixed reg will stay live over an
2842 arbitrary computation. The same applies to the dst reg.
2844 * Temporary regs obtained from getNewRegNCG are distinct from
2845 each other and from all other regs, and stay live over
2846 arbitrary computations.
2850 trivialCode instr maybe_revinstr a b
2853 = getRegister a `thenNat` \ rega ->
2856 then registerCode rega dst `bind` \ code_a ->
2858 instr (OpImm imm_b) (OpReg dst)
2859 else registerCodeF rega `bind` \ code_a ->
2860 registerNameF rega `bind` \ r_a ->
2862 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2863 instr (OpImm imm_b) (OpReg dst)
2865 returnNat (Any IntRep mkcode)
2868 = getRegister b `thenNat` \ regb ->
2869 getNewRegNCG IntRep `thenNat` \ tmp ->
2870 let revinstr_avail = maybeToBool maybe_revinstr
2871 revinstr = case maybe_revinstr of Just ri -> ri
2875 then registerCode regb dst `bind` \ code_b ->
2877 revinstr (OpImm imm_a) (OpReg dst)
2878 else registerCodeF regb `bind` \ code_b ->
2879 registerNameF regb `bind` \ r_b ->
2881 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2882 revinstr (OpImm imm_a) (OpReg dst)
2886 then registerCode regb tmp `bind` \ code_b ->
2888 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2889 instr (OpReg tmp) (OpReg dst)
2890 else registerCodeF regb `bind` \ code_b ->
2891 registerNameF regb `bind` \ r_b ->
2893 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2894 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2895 instr (OpReg tmp) (OpReg dst)
2897 returnNat (Any IntRep mkcode)
2900 = getRegister a `thenNat` \ rega ->
2901 getRegister b `thenNat` \ regb ->
2902 getNewRegNCG IntRep `thenNat` \ tmp ->
2904 = case (isAny rega, isAny regb) of
2906 -> registerCode regb tmp `bind` \ code_b ->
2907 registerCode rega dst `bind` \ code_a ->
2910 instr (OpReg tmp) (OpReg dst)
2912 -> registerCode rega tmp `bind` \ code_a ->
2913 registerCodeF regb `bind` \ code_b ->
2914 registerNameF regb `bind` \ r_b ->
2917 instr (OpReg r_b) (OpReg tmp) `snocOL`
2918 MOV L (OpReg tmp) (OpReg dst)
2920 -> registerCode regb tmp `bind` \ code_b ->
2921 registerCodeF rega `bind` \ code_a ->
2922 registerNameF rega `bind` \ r_a ->
2925 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2926 instr (OpReg tmp) (OpReg dst)
2928 -> registerCodeF rega `bind` \ code_a ->
2929 registerNameF rega `bind` \ r_a ->
2930 registerCodeF regb `bind` \ code_b ->
2931 registerNameF regb `bind` \ r_b ->
2933 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2935 instr (OpReg r_b) (OpReg tmp) `snocOL`
2936 MOV L (OpReg tmp) (OpReg dst)
2938 returnNat (Any IntRep mkcode)
2941 maybe_imm_a = maybeImm a
2942 is_imm_a = maybeToBool maybe_imm_a
2943 imm_a = case maybe_imm_a of Just imm -> imm
2945 maybe_imm_b = maybeImm b
2946 is_imm_b = maybeToBool maybe_imm_b
2947 imm_b = case maybe_imm_b of Just imm -> imm
2951 trivialUCode instr x
2952 = getRegister x `thenNat` \ register ->
2954 code__2 dst = let code = registerCode register dst
2955 src = registerName register dst
2957 if isFixed register && dst /= src
2958 then toOL [MOV L (OpReg src) (OpReg dst),
2960 else unitOL (instr (OpReg src))
2962 returnNat (Any IntRep code__2)
2965 trivialFCode pk instr x y
2966 = getRegister x `thenNat` \ register1 ->
2967 getRegister y `thenNat` \ register2 ->
2968 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2969 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2971 code1 = registerCode register1 tmp1
2972 src1 = registerName register1 tmp1
2974 code2 = registerCode register2 tmp2
2975 src2 = registerName register2 tmp2
2978 -- treat the common case specially: both operands in
2980 | isAny register1 && isAny register2
2983 instr (primRepToSize pk) src1 src2 dst
2985 -- be paranoid (and inefficient)
2987 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2989 instr (primRepToSize pk) tmp1 src2 dst
2991 returnNat (Any DoubleRep code__2)
2995 trivialUFCode pk instr x
2996 = getRegister x `thenNat` \ register ->
2997 getNewRegNCG pk `thenNat` \ tmp ->
2999 code = registerCode register tmp
3000 src = registerName register tmp
3001 code__2 dst = code `snocOL` instr src dst
3003 returnNat (Any pk code__2)
3005 #endif {- i386_TARGET_ARCH -}
3006 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3007 #if sparc_TARGET_ARCH
3009 trivialCode instr x (StInt y)
3011 = getRegister x `thenNat` \ register ->
3012 getNewRegNCG IntRep `thenNat` \ tmp ->
3014 code = registerCode register tmp
3015 src1 = registerName register tmp
3016 src2 = ImmInt (fromInteger y)
3017 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3019 returnNat (Any IntRep code__2)
3021 trivialCode instr x y
3022 = getRegister x `thenNat` \ register1 ->
3023 getRegister y `thenNat` \ register2 ->
3024 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3025 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3027 code1 = registerCode register1 tmp1
3028 src1 = registerName register1 tmp1
3029 code2 = registerCode register2 tmp2
3030 src2 = registerName register2 tmp2
3031 code__2 dst = code1 `appOL` code2 `snocOL`
3032 instr src1 (RIReg src2) dst
3034 returnNat (Any IntRep code__2)
3037 trivialFCode pk instr x y
3038 = getRegister x `thenNat` \ register1 ->
3039 getRegister y `thenNat` \ register2 ->
3040 getNewRegNCG (registerRep register1)
3042 getNewRegNCG (registerRep register2)
3044 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3046 promote x = FxTOy F DF x tmp
3048 pk1 = registerRep register1
3049 code1 = registerCode register1 tmp1
3050 src1 = registerName register1 tmp1
3052 pk2 = registerRep register2
3053 code2 = registerCode register2 tmp2
3054 src2 = registerName register2 tmp2
3058 code1 `appOL` code2 `snocOL`
3059 instr (primRepToSize pk) src1 src2 dst
3060 else if pk1 == FloatRep then
3061 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3062 instr DF tmp src2 dst
3064 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3065 instr DF src1 tmp dst
3067 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3070 trivialUCode instr x
3071 = getRegister x `thenNat` \ register ->
3072 getNewRegNCG IntRep `thenNat` \ tmp ->
3074 code = registerCode register tmp
3075 src = registerName register tmp
3076 code__2 dst = code `snocOL` instr (RIReg src) dst
3078 returnNat (Any IntRep code__2)
3081 trivialUFCode pk instr x
3082 = getRegister x `thenNat` \ register ->
3083 getNewRegNCG pk `thenNat` \ tmp ->
3085 code = registerCode register tmp
3086 src = registerName register tmp
3087 code__2 dst = code `snocOL` instr src dst
3089 returnNat (Any pk code__2)
3091 #endif {- sparc_TARGET_ARCH -}
3094 %************************************************************************
3096 \subsubsection{Coercing to/from integer/floating-point...}
3098 %************************************************************************
3100 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3101 to be generated. Here we just change the type on the Register passed
3102 on up. The code is machine-independent.
3104 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3105 conversions. We have to store temporaries in memory to move
3106 between the integer and the floating point register sets.
3109 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3110 coerceFltCode :: StixTree -> NatM Register
3112 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3113 coerceFP2Int :: StixTree -> NatM Register
3116 = getRegister x `thenNat` \ register ->
3119 Fixed _ reg code -> Fixed pk reg code
3120 Any _ code -> Any pk code
3125 = getRegister x `thenNat` \ register ->
3128 Fixed _ reg code -> Fixed DoubleRep reg code
3129 Any _ code -> Any DoubleRep code
3134 #if alpha_TARGET_ARCH
3137 = getRegister x `thenNat` \ register ->
3138 getNewRegNCG IntRep `thenNat` \ reg ->
3140 code = registerCode register reg
3141 src = registerName register reg
3143 code__2 dst = code . mkSeqInstrs [
3145 LD TF dst (spRel 0),
3148 returnNat (Any DoubleRep code__2)
3152 = getRegister x `thenNat` \ register ->
3153 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3155 code = registerCode register tmp
3156 src = registerName register tmp
3158 code__2 dst = code . mkSeqInstrs [
3160 ST TF tmp (spRel 0),
3163 returnNat (Any IntRep code__2)
3165 #endif {- alpha_TARGET_ARCH -}
3166 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3167 #if i386_TARGET_ARCH
3170 = getRegister x `thenNat` \ register ->
3171 getNewRegNCG IntRep `thenNat` \ reg ->
3173 code = registerCode register reg
3174 src = registerName register reg
3175 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3176 code__2 dst = code `snocOL` opc src dst
3178 returnNat (Any pk code__2)
3182 = getRegister x `thenNat` \ register ->
3183 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3185 code = registerCode register tmp
3186 src = registerName register tmp
3187 pk = registerRep register
3189 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3190 code__2 dst = code `snocOL` opc src dst
3192 returnNat (Any IntRep code__2)
3194 #endif {- i386_TARGET_ARCH -}
3195 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3196 #if sparc_TARGET_ARCH
3199 = getRegister x `thenNat` \ register ->
3200 getNewRegNCG IntRep `thenNat` \ reg ->
3202 code = registerCode register reg
3203 src = registerName register reg
3205 code__2 dst = code `appOL` toOL [
3206 ST W src (spRel (-2)),
3207 LD W (spRel (-2)) dst,
3208 FxTOy W (primRepToSize pk) dst dst]
3210 returnNat (Any pk code__2)
3214 = getRegister x `thenNat` \ register ->
3215 getNewRegNCG IntRep `thenNat` \ reg ->
3216 getNewRegNCG FloatRep `thenNat` \ tmp ->
3218 code = registerCode register reg
3219 src = registerName register reg
3220 pk = registerRep register
3222 code__2 dst = code `appOL` toOL [
3223 FxTOy (primRepToSize pk) W src tmp,
3224 ST W tmp (spRel (-2)),
3225 LD W (spRel (-2)) dst]
3227 returnNat (Any IntRep code__2)
3229 #endif {- sparc_TARGET_ARCH -}
3232 %************************************************************************
3234 \subsubsection{Coercing integer to @Char@...}
3236 %************************************************************************
3238 Integer to character conversion. Where applicable, we try to do this
3239 in one step if the original object is in memory.
3242 chrCode :: StixTree -> NatM Register
3244 #if alpha_TARGET_ARCH
3247 = getRegister x `thenNat` \ register ->
3248 getNewRegNCG IntRep `thenNat` \ reg ->
3250 code = registerCode register reg
3251 src = registerName register reg
3252 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3254 returnNat (Any IntRep code__2)
3256 #endif {- alpha_TARGET_ARCH -}
3257 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3258 #if i386_TARGET_ARCH
3261 = getRegister x `thenNat` \ register ->
3264 code = registerCode register dst
3265 src = registerName register dst
3267 if isFixed register && src /= dst
3268 then toOL [MOV L (OpReg src) (OpReg dst),
3269 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3270 else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3272 returnNat (Any IntRep code__2)
3274 #endif {- i386_TARGET_ARCH -}
3275 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3276 #if sparc_TARGET_ARCH
3278 chrCode (StInd pk mem)
3279 = getAmode mem `thenNat` \ amode ->
3281 code = amodeCode amode
3282 src = amodeAddr amode
3283 src_off = addrOffset src 3
3284 src__2 = case src_off of Just x -> x
3285 code__2 dst = if maybeToBool src_off then
3286 code `snocOL` LD BU src__2 dst
3289 LD (primRepToSize pk) src dst `snocOL`
3290 AND False dst (RIImm (ImmInt 255)) dst
3292 returnNat (Any pk code__2)
3295 = getRegister x `thenNat` \ register ->
3296 getNewRegNCG IntRep `thenNat` \ reg ->
3298 code = registerCode register reg
3299 src = registerName register reg
3300 code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
3302 returnNat (Any IntRep code__2)
3304 #endif {- sparc_TARGET_ARCH -}