2 % (c) The AQUA Project, Glasgow University, 1996
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 #include "HsVersions.h"
13 #include "nativeGen/NCG.h"
15 module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
19 import MachMisc -- may differ per-platform
20 #if __GLASGOW_HASKELL__ >= 202
21 import MachRegs hiding (Addr(..))
22 import qualified MachRegs (Addr(..))
23 #define MachRegsAddr MachRegs.Addr
24 #define MachRegsAddrRegImm MachRegs.AddrRegImm
25 #define MachRegsAddrRegReg MachRegs.AddrRegReg
28 #define MachRegsAddr Addr
29 #define MachRegsAddrRegImm AddrRegImm
30 #define MachRegsAddrRegReg AddrRegReg
33 import AbsCSyn ( MagicId )
34 import AbsCUtils ( magicIdPrimRep )
35 import CLabel ( isAsmTemp, CLabel )
36 import Maybes ( maybeToBool, expectJust )
37 import OrdList -- quite a bit of it
38 import Outputable ( PprStyle(..) )
39 import Pretty ( ptext, rational )
40 import PrimRep ( isFloatingRep, PrimRep(..) )
41 import PrimOp ( PrimOp(..), showPrimOp )
42 import Stix ( getUniqLabelNCG, StixTree(..),
43 StixReg(..), CodeSegment(..)
45 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
46 mapAccumLUs, SYN_IE(UniqSM)
48 import Util ( panic, assertPanic )
51 Code extractor for an entire stix tree---stix statement level.
54 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
56 stmt2Instrs stmt = case stmt of
57 StComment s -> returnInstr (COMMENT s)
58 StSegment seg -> returnInstr (SEGMENT seg)
59 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
60 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
61 StLabel lab -> returnInstr (LABEL lab)
63 StJump arg -> genJump arg
64 StCondJump lab arg -> genCondJump lab arg
65 StCall fn VoidRep args -> genCCall fn VoidRep args
68 | isFloatingRep pk -> assignFltCode pk dst src
69 | otherwise -> assignIntCode pk dst src
72 -- When falling through on the Alpha, we still have to load pv
73 -- with the address of the next routine, so that it can load gp.
74 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
78 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
79 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
80 (foldr1 (.) codes xs))
82 getData :: StixTree -> UniqSM (InstrBlock, Imm)
84 getData (StInt i) = returnUs (id, ImmInteger i)
85 getData (StDouble d) = returnUs (id, dblImmLit d)
86 getData (StLitLbl s) = returnUs (id, ImmLab s)
87 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
88 getData (StCLbl l) = returnUs (id, ImmCLbl l)
89 getData (StString s) =
90 getUniqLabelNCG `thenUs` \ lbl ->
91 returnUs (mkSeqInstrs [LABEL lbl,
92 ASCII True (_UNPK_ s)],
96 %************************************************************************
98 \subsection{General things for putting together code sequences}
100 %************************************************************************
103 type InstrList = OrdList Instr
104 type InstrBlock = InstrList -> InstrList
107 asmVoid = mkEmptyList
109 asmInstr :: Instr -> InstrList
110 asmInstr i = mkUnitList i
112 asmSeq :: [Instr] -> InstrList
113 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
115 asmParThen :: [InstrList] -> InstrBlock
116 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
118 returnInstr :: Instr -> UniqSM InstrBlock
119 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
121 returnInstrs :: [Instr] -> UniqSM InstrBlock
122 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
124 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
125 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
127 mkSeqInstr :: Instr -> InstrBlock
128 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
130 mkSeqInstrs :: [Instr] -> InstrBlock
131 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
135 mangleIndexTree :: StixTree -> StixTree
137 mangleIndexTree (StIndex pk base (StInt i))
138 = StPrim IntAddOp [base, off]
140 off = StInt (i * sizeOf pk)
142 mangleIndexTree (StIndex pk base off)
143 = StPrim IntAddOp [base,
149 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
150 StPrim SllOp [off, StInt s]
154 shift _ = IF_ARCH_alpha(3,2)
158 maybeImm :: StixTree -> Maybe Imm
160 maybeImm (StLitLbl s) = Just (ImmLab s)
161 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
162 maybeImm (StCLbl l) = Just (ImmCLbl l)
165 | i >= toInteger minInt && i <= toInteger maxInt
166 = Just (ImmInt (fromInteger i))
168 = Just (ImmInteger i)
173 %************************************************************************
175 \subsection{The @Register@ type}
177 %************************************************************************
179 @Register@s passed up the tree. If the stix code forces the register
180 to live in a pre-decided machine register, it comes out as @Fixed@;
181 otherwise, it comes out as @Any@, and the parent can decide which
182 register to put it in.
186 = Fixed PrimRep Reg InstrBlock
187 | Any PrimRep (Reg -> InstrBlock)
189 registerCode :: Register -> Reg -> InstrBlock
190 registerCode (Fixed _ _ code) reg = code
191 registerCode (Any _ code) reg = code reg
193 registerName :: Register -> Reg -> Reg
194 registerName (Fixed _ reg _) _ = reg
195 registerName (Any _ _) reg = reg
197 registerRep :: Register -> PrimRep
198 registerRep (Fixed pk _ _) = pk
199 registerRep (Any pk _) = pk
201 isFixed :: Register -> Bool
202 isFixed (Fixed _ _ _) = True
203 isFixed (Any _ _) = False
206 Generate code to get a subtree into a @Register@:
208 getRegister :: StixTree -> UniqSM Register
210 getRegister (StReg (StixMagicId stgreg))
211 = case (magicIdRegMaybe stgreg) of
212 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
215 getRegister (StReg (StixTemp u pk))
216 = returnUs (Fixed pk (UnmappedReg u pk) id)
218 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
220 getRegister (StCall fn kind args)
221 = genCCall fn kind args `thenUs` \ call ->
222 returnUs (Fixed kind reg call)
224 reg = if isFloatingRep kind
225 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
226 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
228 getRegister (StString s)
229 = getUniqLabelNCG `thenUs` \ lbl ->
231 imm_lbl = ImmCLbl lbl
233 code dst = mkSeqInstrs [
236 ASCII True (_UNPK_ s),
238 #if alpha_TARGET_ARCH
239 LDA dst (AddrImm imm_lbl)
242 MOV L (OpImm imm_lbl) (OpReg dst)
244 #if sparc_TARGET_ARCH
245 SETHI (HI imm_lbl) dst,
246 OR False dst (RIImm (LO imm_lbl)) dst
250 returnUs (Any PtrRep code)
252 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
253 = getUniqLabelNCG `thenUs` \ lbl ->
255 imm_lbl = ImmCLbl lbl
257 code dst = mkSeqInstrs [
260 ASCII False (init xs),
262 #if alpha_TARGET_ARCH
263 LDA dst (AddrImm imm_lbl)
266 MOV L (OpImm imm_lbl) (OpReg dst)
268 #if sparc_TARGET_ARCH
269 SETHI (HI imm_lbl) dst,
270 OR False dst (RIImm (LO imm_lbl)) dst
274 returnUs (Any PtrRep code)
276 xs = _UNPK_ (_TAIL_ s)
278 -- end of machine-"independent" bit; here we go on the rest...
280 #if alpha_TARGET_ARCH
282 getRegister (StDouble d)
283 = getUniqLabelNCG `thenUs` \ lbl ->
284 getNewRegNCG PtrRep `thenUs` \ tmp ->
285 let code dst = mkSeqInstrs [
288 DATA TF [ImmLab (rational d)],
290 LDA tmp (AddrImm (ImmCLbl lbl)),
291 LD TF dst (AddrReg tmp)]
293 returnUs (Any DoubleRep code)
295 getRegister (StPrim primop [x]) -- unary PrimOps
297 IntNegOp -> trivialUCode (NEG Q False) x
298 IntAbsOp -> trivialUCode (ABS Q) x
300 NotOp -> trivialUCode NOT x
302 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
303 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
305 OrdOp -> coerceIntCode IntRep x
308 Float2IntOp -> coerceFP2Int x
309 Int2FloatOp -> coerceInt2FP pr x
310 Double2IntOp -> coerceFP2Int x
311 Int2DoubleOp -> coerceInt2FP pr x
313 Double2FloatOp -> coerceFltCode x
314 Float2DoubleOp -> coerceFltCode x
316 other_op -> getRegister (StCall fn DoubleRep [x])
318 fn = case other_op of
319 FloatExpOp -> SLIT("exp")
320 FloatLogOp -> SLIT("log")
321 FloatSqrtOp -> SLIT("sqrt")
322 FloatSinOp -> SLIT("sin")
323 FloatCosOp -> SLIT("cos")
324 FloatTanOp -> SLIT("tan")
325 FloatAsinOp -> SLIT("asin")
326 FloatAcosOp -> SLIT("acos")
327 FloatAtanOp -> SLIT("atan")
328 FloatSinhOp -> SLIT("sinh")
329 FloatCoshOp -> SLIT("cosh")
330 FloatTanhOp -> SLIT("tanh")
331 DoubleExpOp -> SLIT("exp")
332 DoubleLogOp -> SLIT("log")
333 DoubleSqrtOp -> SLIT("sqrt")
334 DoubleSinOp -> SLIT("sin")
335 DoubleCosOp -> SLIT("cos")
336 DoubleTanOp -> SLIT("tan")
337 DoubleAsinOp -> SLIT("asin")
338 DoubleAcosOp -> SLIT("acos")
339 DoubleAtanOp -> SLIT("atan")
340 DoubleSinhOp -> SLIT("sinh")
341 DoubleCoshOp -> SLIT("cosh")
342 DoubleTanhOp -> SLIT("tanh")
344 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
346 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
348 CharGtOp -> trivialCode (CMP LTT) y x
349 CharGeOp -> trivialCode (CMP LE) y x
350 CharEqOp -> trivialCode (CMP EQQ) x y
351 CharNeOp -> int_NE_code x y
352 CharLtOp -> trivialCode (CMP LTT) x y
353 CharLeOp -> trivialCode (CMP LE) x y
355 IntGtOp -> trivialCode (CMP LTT) y x
356 IntGeOp -> trivialCode (CMP LE) y x
357 IntEqOp -> trivialCode (CMP EQQ) x y
358 IntNeOp -> int_NE_code x y
359 IntLtOp -> trivialCode (CMP LTT) x y
360 IntLeOp -> trivialCode (CMP LE) x y
362 WordGtOp -> trivialCode (CMP ULT) y x
363 WordGeOp -> trivialCode (CMP ULE) x y
364 WordEqOp -> trivialCode (CMP EQQ) x y
365 WordNeOp -> int_NE_code x y
366 WordLtOp -> trivialCode (CMP ULT) x y
367 WordLeOp -> trivialCode (CMP ULE) x y
369 AddrGtOp -> trivialCode (CMP ULT) y x
370 AddrGeOp -> trivialCode (CMP ULE) y x
371 AddrEqOp -> trivialCode (CMP EQQ) x y
372 AddrNeOp -> int_NE_code x y
373 AddrLtOp -> trivialCode (CMP ULT) x y
374 AddrLeOp -> trivialCode (CMP ULE) x y
376 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
377 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
378 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
379 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
380 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
381 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
383 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
384 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
385 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
386 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
387 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
388 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
390 IntAddOp -> trivialCode (ADD Q False) x y
391 IntSubOp -> trivialCode (SUB Q False) x y
392 IntMulOp -> trivialCode (MUL Q False) x y
393 IntQuotOp -> trivialCode (DIV Q False) x y
394 IntRemOp -> trivialCode (REM Q False) x y
396 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
397 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
398 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
399 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
401 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
402 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
403 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
404 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
406 AndOp -> trivialCode AND x y
407 OrOp -> trivialCode OR x y
408 SllOp -> trivialCode SLL x y
409 SraOp -> trivialCode SRA x y
410 SrlOp -> trivialCode SRL x y
412 ISllOp -> panic "AlphaGen:isll"
413 ISraOp -> panic "AlphaGen:isra"
414 ISrlOp -> panic "AlphaGen:isrl"
416 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
417 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
419 {- ------------------------------------------------------------
420 Some bizarre special code for getting condition codes into
421 registers. Integer non-equality is a test for equality
422 followed by an XOR with 1. (Integer comparisons always set
423 the result register to 0 or 1.) Floating point comparisons of
424 any kind leave the result in a floating point register, so we
425 need to wrangle an integer register out of things.
427 int_NE_code :: StixTree -> StixTree -> UniqSM Register
430 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
431 getNewRegNCG IntRep `thenUs` \ tmp ->
433 code = registerCode register tmp
434 src = registerName register tmp
435 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
437 returnUs (Any IntRep code__2)
439 {- ------------------------------------------------------------
440 Comments for int_NE_code also apply to cmpF_code
443 :: (Reg -> Reg -> Reg -> Instr)
445 -> StixTree -> StixTree
448 cmpF_code instr cond x y
449 = trivialFCode pr instr x y `thenUs` \ register ->
450 getNewRegNCG DoubleRep `thenUs` \ tmp ->
451 getUniqLabelNCG `thenUs` \ lbl ->
453 code = registerCode register tmp
454 result = registerName register tmp
456 code__2 dst = code . mkSeqInstrs [
457 OR zeroh (RIImm (ImmInt 1)) dst,
458 BF cond result (ImmCLbl lbl),
459 OR zeroh (RIReg zeroh) dst,
462 returnUs (Any IntRep code__2)
464 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
465 ------------------------------------------------------------
467 getRegister (StInd pk mem)
468 = getAmode mem `thenUs` \ amode ->
470 code = amodeCode amode
471 src = amodeAddr amode
472 size = primRepToSize pk
473 code__2 dst = code . mkSeqInstr (LD size dst src)
475 returnUs (Any pk code__2)
477 getRegister (StInt i)
480 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
482 returnUs (Any IntRep code)
485 code dst = mkSeqInstr (LDI Q dst src)
487 returnUs (Any IntRep code)
489 src = ImmInt (fromInteger i)
494 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
496 returnUs (Any PtrRep code)
499 imm__2 = case imm of Just x -> x
501 #endif {- alpha_TARGET_ARCH -}
502 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
505 getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
507 getRegister (StDouble 0.0)
509 code dst = mkSeqInstrs [FLDZ]
511 returnUs (Any DoubleRep code)
513 getRegister (StDouble 1.0)
515 code dst = mkSeqInstrs [FLD1]
517 returnUs (Any DoubleRep code)
519 getRegister (StDouble d)
520 = getUniqLabelNCG `thenUs` \ lbl ->
521 --getNewRegNCG PtrRep `thenUs` \ tmp ->
522 let code dst = mkSeqInstrs [
525 DATA DF [dblImmLit d],
527 FLD DF (OpImm (ImmCLbl lbl))
530 returnUs (Any DoubleRep code)
532 getRegister (StPrim primop [x]) -- unary PrimOps
534 IntNegOp -> trivialUCode (NEGI L) x
535 IntAbsOp -> absIntCode x
537 NotOp -> trivialUCode (NOT L) x
539 FloatNegOp -> trivialUFCode FloatRep FCHS x
540 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
541 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
543 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
545 OrdOp -> coerceIntCode IntRep x
548 Float2IntOp -> coerceFP2Int x
549 Int2FloatOp -> coerceInt2FP FloatRep x
550 Double2IntOp -> coerceFP2Int x
551 Int2DoubleOp -> coerceInt2FP DoubleRep x
553 Double2FloatOp -> coerceFltCode x
554 Float2DoubleOp -> coerceFltCode x
558 fixed_x = if is_float_op -- promote to double
559 then StPrim Float2DoubleOp [x]
562 getRegister (StCall fn DoubleRep [x])
566 FloatExpOp -> (True, SLIT("exp"))
567 FloatLogOp -> (True, SLIT("log"))
569 FloatSinOp -> (True, SLIT("sin"))
570 FloatCosOp -> (True, SLIT("cos"))
571 FloatTanOp -> (True, SLIT("tan"))
573 FloatAsinOp -> (True, SLIT("asin"))
574 FloatAcosOp -> (True, SLIT("acos"))
575 FloatAtanOp -> (True, SLIT("atan"))
577 FloatSinhOp -> (True, SLIT("sinh"))
578 FloatCoshOp -> (True, SLIT("cosh"))
579 FloatTanhOp -> (True, SLIT("tanh"))
581 DoubleExpOp -> (False, SLIT("exp"))
582 DoubleLogOp -> (False, SLIT("log"))
584 DoubleSinOp -> (False, SLIT("sin"))
585 DoubleCosOp -> (False, SLIT("cos"))
586 DoubleTanOp -> (False, SLIT("tan"))
588 DoubleAsinOp -> (False, SLIT("asin"))
589 DoubleAcosOp -> (False, SLIT("acos"))
590 DoubleAtanOp -> (False, SLIT("atan"))
592 DoubleSinhOp -> (False, SLIT("sinh"))
593 DoubleCoshOp -> (False, SLIT("cosh"))
594 DoubleTanhOp -> (False, SLIT("tanh"))
596 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
598 CharGtOp -> condIntReg GTT x y
599 CharGeOp -> condIntReg GE x y
600 CharEqOp -> condIntReg EQQ x y
601 CharNeOp -> condIntReg NE x y
602 CharLtOp -> condIntReg LTT x y
603 CharLeOp -> condIntReg LE x y
605 IntGtOp -> condIntReg GTT x y
606 IntGeOp -> condIntReg GE x y
607 IntEqOp -> condIntReg EQQ x y
608 IntNeOp -> condIntReg NE x y
609 IntLtOp -> condIntReg LTT x y
610 IntLeOp -> condIntReg LE x y
612 WordGtOp -> condIntReg GU x y
613 WordGeOp -> condIntReg GEU x y
614 WordEqOp -> condIntReg EQQ x y
615 WordNeOp -> condIntReg NE x y
616 WordLtOp -> condIntReg LU x y
617 WordLeOp -> condIntReg LEU x y
619 AddrGtOp -> condIntReg GU x y
620 AddrGeOp -> condIntReg GEU x y
621 AddrEqOp -> condIntReg EQQ x y
622 AddrNeOp -> condIntReg NE x y
623 AddrLtOp -> condIntReg LU x y
624 AddrLeOp -> condIntReg LEU x y
626 FloatGtOp -> condFltReg GTT x y
627 FloatGeOp -> condFltReg GE x y
628 FloatEqOp -> condFltReg EQQ x y
629 FloatNeOp -> condFltReg NE x y
630 FloatLtOp -> condFltReg LTT x y
631 FloatLeOp -> condFltReg LE x y
633 DoubleGtOp -> condFltReg GTT x y
634 DoubleGeOp -> condFltReg GE x y
635 DoubleEqOp -> condFltReg EQQ x y
636 DoubleNeOp -> condFltReg NE x y
637 DoubleLtOp -> condFltReg LTT x y
638 DoubleLeOp -> condFltReg LE x y
640 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
641 -- this should be optimised by the generic Opts,
642 -- I don't know why it is not (sometimes)!
644 [x, StInt 0] -> getRegister x
649 IntSubOp -> sub_code L x y
650 IntQuotOp -> quot_code L x y True{-division-}
651 IntRemOp -> quot_code L x y False{-remainder-}
652 IntMulOp -> trivialCode (IMUL L) x y {-True-}
654 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
655 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
656 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
657 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
659 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
660 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
661 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
662 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
664 AndOp -> trivialCode (AND L) x y {-True-}
665 OrOp -> trivialCode (OR L) x y {-True-}
666 SllOp -> trivialCode (SHL L) x y {-False-}
667 SraOp -> trivialCode (SAR L) x y {-False-}
668 SrlOp -> trivialCode (SHR L) x y {-False-}
670 ISllOp -> panic "I386Gen:isll"
671 ISraOp -> panic "I386Gen:isra"
672 ISrlOp -> panic "I386Gen:isrl"
674 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
675 where promote x = StPrim Float2DoubleOp [x]
676 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
678 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
680 add_code sz x (StInt y)
681 = getRegister x `thenUs` \ register ->
682 getNewRegNCG IntRep `thenUs` \ tmp ->
684 code = registerCode register tmp
685 src1 = registerName register tmp
686 src2 = ImmInt (fromInteger y)
688 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
690 returnUs (Any IntRep code__2)
692 add_code sz x (StInd _ mem)
693 = getRegister x `thenUs` \ register1 ->
694 --getNewRegNCG (registerRep register1)
695 -- `thenUs` \ tmp1 ->
696 getAmode mem `thenUs` \ amode ->
698 code2 = amodeCode amode
699 src2 = amodeAddr amode
701 fixedname = registerName register1 eax
702 code__2 dst = let code1 = registerCode register1 dst
703 src1 = registerName register1 dst
704 in asmParThen [code2 asmVoid,code1 asmVoid] .
705 if isFixed register1 && src1 /= dst
706 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
707 ADD sz (OpAddr src2) (OpReg dst)]
709 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
711 returnUs (Any IntRep code__2)
713 add_code sz (StInd _ mem) y
714 = getRegister y `thenUs` \ register2 ->
715 --getNewRegNCG (registerRep register2)
716 -- `thenUs` \ tmp2 ->
717 getAmode mem `thenUs` \ amode ->
719 code1 = amodeCode amode
720 src1 = amodeAddr amode
722 fixedname = registerName register2 eax
723 code__2 dst = let code2 = registerCode register2 dst
724 src2 = registerName register2 dst
725 in asmParThen [code1 asmVoid,code2 asmVoid] .
726 if isFixed register2 && src2 /= dst
727 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
728 ADD sz (OpAddr src1) (OpReg dst)]
730 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
732 returnUs (Any IntRep code__2)
735 = getRegister x `thenUs` \ register1 ->
736 getRegister y `thenUs` \ register2 ->
737 getNewRegNCG IntRep `thenUs` \ tmp1 ->
738 getNewRegNCG IntRep `thenUs` \ tmp2 ->
740 code1 = registerCode register1 tmp1 asmVoid
741 src1 = registerName register1 tmp1
742 code2 = registerCode register2 tmp2 asmVoid
743 src2 = registerName register2 tmp2
744 code__2 dst = asmParThen [code1, code2] .
745 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
747 returnUs (Any IntRep code__2)
750 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
752 sub_code sz x (StInt y)
753 = getRegister x `thenUs` \ register ->
754 getNewRegNCG IntRep `thenUs` \ tmp ->
756 code = registerCode register tmp
757 src1 = registerName register tmp
758 src2 = ImmInt (-(fromInteger y))
760 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
762 returnUs (Any IntRep code__2)
764 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
769 -> StixTree -> StixTree
770 -> Bool -- True => division, False => remainder operation
773 -- x must go into eax, edx must be a sign-extension of eax, and y
774 -- should go in some other register (or memory), so that we get
775 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
776 -- put y in memory (if it is not there already)
778 quot_code sz x (StInd pk mem) is_division
779 = getRegister x `thenUs` \ register1 ->
780 getNewRegNCG IntRep `thenUs` \ tmp1 ->
781 getAmode mem `thenUs` \ amode ->
783 code1 = registerCode register1 tmp1 asmVoid
784 src1 = registerName register1 tmp1
785 code2 = amodeCode amode asmVoid
786 src2 = amodeAddr amode
787 code__2 = asmParThen [code1, code2] .
788 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
790 IDIV sz (OpAddr src2)]
792 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
794 quot_code sz x (StInt i) is_division
795 = getRegister x `thenUs` \ register1 ->
796 getNewRegNCG IntRep `thenUs` \ tmp1 ->
798 code1 = registerCode register1 tmp1 asmVoid
799 src1 = registerName register1 tmp1
800 src2 = ImmInt (fromInteger i)
801 code__2 = asmParThen [code1] .
802 mkSeqInstrs [-- we put src2 in (ebx)
803 MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
804 MOV L (OpReg src1) (OpReg eax),
806 IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
808 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
810 quot_code sz x y is_division
811 = getRegister x `thenUs` \ register1 ->
812 getNewRegNCG IntRep `thenUs` \ tmp1 ->
813 getRegister y `thenUs` \ register2 ->
814 getNewRegNCG IntRep `thenUs` \ tmp2 ->
816 code1 = registerCode register1 tmp1 asmVoid
817 src1 = registerName register1 tmp1
818 code2 = registerCode register2 tmp2 asmVoid
819 src2 = registerName register2 tmp2
820 code__2 = asmParThen [code1, code2] .
821 if src2 == ecx || src2 == esi
822 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
824 IDIV sz (OpReg src2)]
825 else mkSeqInstrs [ -- we put src2 in (ebx)
826 MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
827 MOV L (OpReg src1) (OpReg eax),
829 IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
831 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
832 -----------------------
834 getRegister (StInd pk mem)
835 = getAmode mem `thenUs` \ amode ->
837 code = amodeCode amode
838 src = amodeAddr amode
839 size = primRepToSize pk
841 if pk == DoubleRep || pk == FloatRep
842 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
843 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
845 returnUs (Any pk code__2)
848 getRegister (StInt i)
850 src = ImmInt (fromInteger i)
851 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
853 returnUs (Any IntRep code)
858 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
860 returnUs (Any PtrRep code)
863 imm__2 = case imm of Just x -> x
865 #endif {- i386_TARGET_ARCH -}
866 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
867 #if sparc_TARGET_ARCH
869 getRegister (StDouble d)
870 = getUniqLabelNCG `thenUs` \ lbl ->
871 getNewRegNCG PtrRep `thenUs` \ tmp ->
872 let code dst = mkSeqInstrs [
875 DATA DF [dblImmLit d],
877 SETHI (HI (ImmCLbl lbl)) tmp,
878 LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst]
880 returnUs (Any DoubleRep code)
882 getRegister (StPrim primop [x]) -- unary PrimOps
884 IntNegOp -> trivialUCode (SUB False False g0) x
885 IntAbsOp -> absIntCode x
886 NotOp -> trivialUCode (XNOR False g0) x
888 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
890 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
892 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
893 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
895 OrdOp -> coerceIntCode IntRep x
898 Float2IntOp -> coerceFP2Int x
899 Int2FloatOp -> coerceInt2FP FloatRep x
900 Double2IntOp -> coerceFP2Int x
901 Int2DoubleOp -> coerceInt2FP DoubleRep x
905 fixed_x = if is_float_op -- promote to double
906 then StPrim Float2DoubleOp [x]
909 getRegister (StCall fn DoubleRep [x])
913 FloatExpOp -> (True, SLIT("exp"))
914 FloatLogOp -> (True, SLIT("log"))
915 FloatSqrtOp -> (True, SLIT("sqrt"))
917 FloatSinOp -> (True, SLIT("sin"))
918 FloatCosOp -> (True, SLIT("cos"))
919 FloatTanOp -> (True, SLIT("tan"))
921 FloatAsinOp -> (True, SLIT("asin"))
922 FloatAcosOp -> (True, SLIT("acos"))
923 FloatAtanOp -> (True, SLIT("atan"))
925 FloatSinhOp -> (True, SLIT("sinh"))
926 FloatCoshOp -> (True, SLIT("cosh"))
927 FloatTanhOp -> (True, SLIT("tanh"))
929 DoubleExpOp -> (False, SLIT("exp"))
930 DoubleLogOp -> (False, SLIT("log"))
931 DoubleSqrtOp -> (True, SLIT("sqrt"))
933 DoubleSinOp -> (False, SLIT("sin"))
934 DoubleCosOp -> (False, SLIT("cos"))
935 DoubleTanOp -> (False, SLIT("tan"))
937 DoubleAsinOp -> (False, SLIT("asin"))
938 DoubleAcosOp -> (False, SLIT("acos"))
939 DoubleAtanOp -> (False, SLIT("atan"))
941 DoubleSinhOp -> (False, SLIT("sinh"))
942 DoubleCoshOp -> (False, SLIT("cosh"))
943 DoubleTanhOp -> (False, SLIT("tanh"))
944 _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
946 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
948 CharGtOp -> condIntReg GTT x y
949 CharGeOp -> condIntReg GE x y
950 CharEqOp -> condIntReg EQQ x y
951 CharNeOp -> condIntReg NE x y
952 CharLtOp -> condIntReg LTT x y
953 CharLeOp -> condIntReg LE x y
955 IntGtOp -> condIntReg GTT x y
956 IntGeOp -> condIntReg GE x y
957 IntEqOp -> condIntReg EQQ x y
958 IntNeOp -> condIntReg NE x y
959 IntLtOp -> condIntReg LTT x y
960 IntLeOp -> condIntReg LE x y
962 WordGtOp -> condIntReg GU x y
963 WordGeOp -> condIntReg GEU x y
964 WordEqOp -> condIntReg EQQ x y
965 WordNeOp -> condIntReg NE x y
966 WordLtOp -> condIntReg LU x y
967 WordLeOp -> condIntReg LEU x y
969 AddrGtOp -> condIntReg GU x y
970 AddrGeOp -> condIntReg GEU x y
971 AddrEqOp -> condIntReg EQQ x y
972 AddrNeOp -> condIntReg NE x y
973 AddrLtOp -> condIntReg LU x y
974 AddrLeOp -> condIntReg LEU x y
976 FloatGtOp -> condFltReg GTT x y
977 FloatGeOp -> condFltReg GE x y
978 FloatEqOp -> condFltReg EQQ x y
979 FloatNeOp -> condFltReg NE x y
980 FloatLtOp -> condFltReg LTT x y
981 FloatLeOp -> condFltReg LE x y
983 DoubleGtOp -> condFltReg GTT x y
984 DoubleGeOp -> condFltReg GE x y
985 DoubleEqOp -> condFltReg EQQ x y
986 DoubleNeOp -> condFltReg NE x y
987 DoubleLtOp -> condFltReg LTT x y
988 DoubleLeOp -> condFltReg LE x y
990 IntAddOp -> trivialCode (ADD False False) x y
991 IntSubOp -> trivialCode (SUB False False) x y
993 -- ToDo: teach about V8+ SPARC mul/div instructions
994 IntMulOp -> imul_div SLIT(".umul") x y
995 IntQuotOp -> imul_div SLIT(".div") x y
996 IntRemOp -> imul_div SLIT(".rem") x y
998 FloatAddOp -> trivialFCode FloatRep FADD x y
999 FloatSubOp -> trivialFCode FloatRep FSUB x y
1000 FloatMulOp -> trivialFCode FloatRep FMUL x y
1001 FloatDivOp -> trivialFCode FloatRep FDIV x y
1003 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1004 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1005 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1006 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1008 AndOp -> trivialCode (AND False) x y
1009 OrOp -> trivialCode (OR False) x y
1010 SllOp -> trivialCode SLL x y
1011 SraOp -> trivialCode SRA x y
1012 SrlOp -> trivialCode SRL x y
1014 ISllOp -> panic "SparcGen:isll"
1015 ISraOp -> panic "SparcGen:isra"
1016 ISrlOp -> panic "SparcGen:isrl"
1018 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1019 where promote x = StPrim Float2DoubleOp [x]
1020 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1022 imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1024 getRegister (StInd pk mem)
1025 = getAmode mem `thenUs` \ amode ->
1027 code = amodeCode amode
1028 src = amodeAddr amode
1029 size = primRepToSize pk
1030 code__2 dst = code . mkSeqInstr (LD size src dst)
1032 returnUs (Any pk code__2)
1034 getRegister (StInt i)
1037 src = ImmInt (fromInteger i)
1038 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1040 returnUs (Any IntRep code)
1045 code dst = mkSeqInstrs [
1046 SETHI (HI imm__2) dst,
1047 OR False dst (RIImm (LO imm__2)) dst]
1049 returnUs (Any PtrRep code)
1052 imm__2 = case imm of Just x -> x
1054 #endif {- sparc_TARGET_ARCH -}
1057 %************************************************************************
1059 \subsection{The @Amode@ type}
1061 %************************************************************************
1063 @Amode@s: Memory addressing modes passed up the tree.
1065 data Amode = Amode MachRegsAddr InstrBlock
1067 amodeAddr (Amode addr _) = addr
1068 amodeCode (Amode _ code) = code
1071 Now, given a tree (the argument to an StInd) that references memory,
1072 produce a suitable addressing mode.
1075 getAmode :: StixTree -> UniqSM Amode
1077 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1079 #if alpha_TARGET_ARCH
1081 getAmode (StPrim IntSubOp [x, StInt i])
1082 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1083 getRegister x `thenUs` \ register ->
1085 code = registerCode register tmp
1086 reg = registerName register tmp
1087 off = ImmInt (-(fromInteger i))
1089 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1091 getAmode (StPrim IntAddOp [x, StInt i])
1092 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1093 getRegister x `thenUs` \ register ->
1095 code = registerCode register tmp
1096 reg = registerName register tmp
1097 off = ImmInt (fromInteger i)
1099 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1103 = returnUs (Amode (AddrImm imm__2) id)
1106 imm__2 = case imm of Just x -> x
1109 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1110 getRegister other `thenUs` \ register ->
1112 code = registerCode register tmp
1113 reg = registerName register tmp
1115 returnUs (Amode (AddrReg reg) code)
1117 #endif {- alpha_TARGET_ARCH -}
1118 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1119 #if i386_TARGET_ARCH
1121 getAmode (StPrim IntSubOp [x, StInt i])
1122 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1123 getRegister x `thenUs` \ register ->
1125 code = registerCode register tmp
1126 reg = registerName register tmp
1127 off = ImmInt (-(fromInteger i))
1129 returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
1131 getAmode (StPrim IntAddOp [x, StInt i])
1134 code = mkSeqInstrs []
1136 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1139 imm__2 = case imm of Just x -> x
1141 getAmode (StPrim IntAddOp [x, StInt i])
1142 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1143 getRegister x `thenUs` \ register ->
1145 code = registerCode register tmp
1146 reg = registerName register tmp
1147 off = ImmInt (fromInteger i)
1149 returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
1151 getAmode (StPrim IntAddOp [x, y])
1152 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1153 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1154 getRegister x `thenUs` \ register1 ->
1155 getRegister y `thenUs` \ register2 ->
1157 code1 = registerCode register1 tmp1 asmVoid
1158 reg1 = registerName register1 tmp1
1159 code2 = registerCode register2 tmp2 asmVoid
1160 reg2 = registerName register2 tmp2
1161 code__2 = asmParThen [code1, code2]
1163 returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1168 code = mkSeqInstrs []
1170 returnUs (Amode (ImmAddr imm__2 0) code)
1173 imm__2 = case imm of Just x -> x
1176 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1177 getRegister other `thenUs` \ register ->
1179 code = registerCode register tmp
1180 reg = registerName register tmp
1183 returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code)
1185 #endif {- i386_TARGET_ARCH -}
1186 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1187 #if sparc_TARGET_ARCH
1189 getAmode (StPrim IntSubOp [x, StInt i])
1191 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1192 getRegister x `thenUs` \ register ->
1194 code = registerCode register tmp
1195 reg = registerName register tmp
1196 off = ImmInt (-(fromInteger i))
1198 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1201 getAmode (StPrim IntAddOp [x, StInt i])
1203 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1204 getRegister x `thenUs` \ register ->
1206 code = registerCode register tmp
1207 reg = registerName register tmp
1208 off = ImmInt (fromInteger i)
1210 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1212 getAmode (StPrim IntAddOp [x, y])
1213 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1214 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1215 getRegister x `thenUs` \ register1 ->
1216 getRegister y `thenUs` \ register2 ->
1218 code1 = registerCode register1 tmp1 asmVoid
1219 reg1 = registerName register1 tmp1
1220 code2 = registerCode register2 tmp2 asmVoid
1221 reg2 = registerName register2 tmp2
1222 code__2 = asmParThen [code1, code2]
1224 returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2)
1228 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1230 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1232 returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code)
1235 imm__2 = case imm of Just x -> x
1238 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1239 getRegister other `thenUs` \ register ->
1241 code = registerCode register tmp
1242 reg = registerName register tmp
1245 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1247 #endif {- sparc_TARGET_ARCH -}
1250 %************************************************************************
1252 \subsection{The @CondCode@ type}
1254 %************************************************************************
1256 Condition codes passed up the tree.
1258 data CondCode = CondCode Bool Cond InstrBlock
1260 condName (CondCode _ cond _) = cond
1261 condFloat (CondCode is_float _ _) = is_float
1262 condCode (CondCode _ _ code) = code
1265 Set up a condition code for a conditional branch.
1268 getCondCode :: StixTree -> UniqSM CondCode
1270 #if alpha_TARGET_ARCH
1271 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1272 #endif {- alpha_TARGET_ARCH -}
1273 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1275 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1276 -- yes, they really do seem to want exactly the same!
1278 getCondCode (StPrim primop [x, y])
1280 CharGtOp -> condIntCode GTT x y
1281 CharGeOp -> condIntCode GE x y
1282 CharEqOp -> condIntCode EQQ x y
1283 CharNeOp -> condIntCode NE x y
1284 CharLtOp -> condIntCode LTT x y
1285 CharLeOp -> condIntCode LE x y
1287 IntGtOp -> condIntCode GTT x y
1288 IntGeOp -> condIntCode GE x y
1289 IntEqOp -> condIntCode EQQ x y
1290 IntNeOp -> condIntCode NE x y
1291 IntLtOp -> condIntCode LTT x y
1292 IntLeOp -> condIntCode LE x y
1294 WordGtOp -> condIntCode GU x y
1295 WordGeOp -> condIntCode GEU x y
1296 WordEqOp -> condIntCode EQQ x y
1297 WordNeOp -> condIntCode NE x y
1298 WordLtOp -> condIntCode LU x y
1299 WordLeOp -> condIntCode LEU x y
1301 AddrGtOp -> condIntCode GU x y
1302 AddrGeOp -> condIntCode GEU x y
1303 AddrEqOp -> condIntCode EQQ x y
1304 AddrNeOp -> condIntCode NE x y
1305 AddrLtOp -> condIntCode LU x y
1306 AddrLeOp -> condIntCode LEU x y
1308 FloatGtOp -> condFltCode GTT x y
1309 FloatGeOp -> condFltCode GE x y
1310 FloatEqOp -> condFltCode EQQ x y
1311 FloatNeOp -> condFltCode NE x y
1312 FloatLtOp -> condFltCode LTT x y
1313 FloatLeOp -> condFltCode LE x y
1315 DoubleGtOp -> condFltCode GTT x y
1316 DoubleGeOp -> condFltCode GE x y
1317 DoubleEqOp -> condFltCode EQQ x y
1318 DoubleNeOp -> condFltCode NE x y
1319 DoubleLtOp -> condFltCode LTT x y
1320 DoubleLeOp -> condFltCode LE x y
1322 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1327 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1328 passed back up the tree.
1331 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1333 #if alpha_TARGET_ARCH
1334 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1335 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1336 #endif {- alpha_TARGET_ARCH -}
1338 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1339 #if i386_TARGET_ARCH
1341 condIntCode cond (StInd _ x) y
1343 = getAmode x `thenUs` \ amode ->
1345 code1 = amodeCode amode asmVoid
1346 y__2 = amodeAddr amode
1347 code__2 = asmParThen [code1] .
1348 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1350 returnUs (CondCode False cond code__2)
1353 imm__2 = case imm of Just x -> x
1355 condIntCode cond x (StInt 0)
1356 = getRegister x `thenUs` \ register1 ->
1357 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1359 code1 = registerCode register1 tmp1 asmVoid
1360 src1 = registerName register1 tmp1
1361 code__2 = asmParThen [code1] .
1362 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1364 returnUs (CondCode False cond code__2)
1366 condIntCode cond x y
1368 = getRegister x `thenUs` \ register1 ->
1369 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1371 code1 = registerCode register1 tmp1 asmVoid
1372 src1 = registerName register1 tmp1
1373 code__2 = asmParThen [code1] .
1374 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1376 returnUs (CondCode False cond code__2)
1379 imm__2 = case imm of Just x -> x
1381 condIntCode cond (StInd _ x) y
1382 = getAmode x `thenUs` \ amode ->
1383 getRegister y `thenUs` \ register2 ->
1384 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1386 code1 = amodeCode amode asmVoid
1387 src1 = amodeAddr amode
1388 code2 = registerCode register2 tmp2 asmVoid
1389 src2 = registerName register2 tmp2
1390 code__2 = asmParThen [code1, code2] .
1391 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1393 returnUs (CondCode False cond code__2)
1395 condIntCode cond y (StInd _ x)
1396 = getAmode x `thenUs` \ amode ->
1397 getRegister y `thenUs` \ register2 ->
1398 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1400 code1 = amodeCode amode asmVoid
1401 src1 = amodeAddr amode
1402 code2 = registerCode register2 tmp2 asmVoid
1403 src2 = registerName register2 tmp2
1404 code__2 = asmParThen [code1, code2] .
1405 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1407 returnUs (CondCode False cond code__2)
1409 condIntCode cond x y
1410 = getRegister x `thenUs` \ register1 ->
1411 getRegister y `thenUs` \ register2 ->
1412 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1413 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1415 code1 = registerCode register1 tmp1 asmVoid
1416 src1 = registerName register1 tmp1
1417 code2 = registerCode register2 tmp2 asmVoid
1418 src2 = registerName register2 tmp2
1419 code__2 = asmParThen [code1, code2] .
1420 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1422 returnUs (CondCode False cond code__2)
1426 condFltCode cond x (StDouble 0.0)
1427 = getRegister x `thenUs` \ register1 ->
1428 getNewRegNCG (registerRep register1)
1431 pk1 = registerRep register1
1432 code1 = registerCode register1 tmp1
1433 src1 = registerName register1 tmp1
1435 code__2 = asmParThen [code1 asmVoid] .
1436 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1438 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1439 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1443 returnUs (CondCode True (fix_FP_cond cond) code__2)
1445 condFltCode cond x y
1446 = getRegister x `thenUs` \ register1 ->
1447 getRegister y `thenUs` \ register2 ->
1448 getNewRegNCG (registerRep register1)
1450 getNewRegNCG (registerRep register2)
1453 pk1 = registerRep register1
1454 code1 = registerCode register1 tmp1
1455 src1 = registerName register1 tmp1
1457 code2 = registerCode register2 tmp2
1458 src2 = registerName register2 tmp2
1460 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1461 mkSeqInstrs [FUCOMPP,
1463 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1464 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1468 returnUs (CondCode True (fix_FP_cond cond) code__2)
1470 {- On the 486, the flags set by FP compare are the unsigned ones!
1471 (This looks like a HACK to me. WDP 96/03)
1474 fix_FP_cond :: Cond -> Cond
1476 fix_FP_cond GE = GEU
1477 fix_FP_cond GTT = GU
1478 fix_FP_cond LTT = LU
1479 fix_FP_cond LE = LEU
1480 fix_FP_cond any = any
1482 #endif {- i386_TARGET_ARCH -}
1483 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1484 #if sparc_TARGET_ARCH
1486 condIntCode cond x (StInt y)
1488 = getRegister x `thenUs` \ register ->
1489 getNewRegNCG IntRep `thenUs` \ tmp ->
1491 code = registerCode register tmp
1492 src1 = registerName register tmp
1493 src2 = ImmInt (fromInteger y)
1494 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1496 returnUs (CondCode False cond code__2)
1498 condIntCode cond x y
1499 = getRegister x `thenUs` \ register1 ->
1500 getRegister y `thenUs` \ register2 ->
1501 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1502 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1504 code1 = registerCode register1 tmp1 asmVoid
1505 src1 = registerName register1 tmp1
1506 code2 = registerCode register2 tmp2 asmVoid
1507 src2 = registerName register2 tmp2
1508 code__2 = asmParThen [code1, code2] .
1509 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1511 returnUs (CondCode False cond code__2)
1514 condFltCode cond x y
1515 = getRegister x `thenUs` \ register1 ->
1516 getRegister y `thenUs` \ register2 ->
1517 getNewRegNCG (registerRep register1)
1519 getNewRegNCG (registerRep register2)
1521 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1523 promote x = asmInstr (FxTOy F DF x tmp)
1525 pk1 = registerRep register1
1526 code1 = registerCode register1 tmp1
1527 src1 = registerName register1 tmp1
1529 pk2 = registerRep register2
1530 code2 = registerCode register2 tmp2
1531 src2 = registerName register2 tmp2
1535 asmParThen [code1 asmVoid, code2 asmVoid] .
1536 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1537 else if pk1 == FloatRep then
1538 asmParThen [code1 (promote src1), code2 asmVoid] .
1539 mkSeqInstr (FCMP True DF tmp src2)
1541 asmParThen [code1 asmVoid, code2 (promote src2)] .
1542 mkSeqInstr (FCMP True DF src1 tmp)
1544 returnUs (CondCode True cond code__2)
1546 #endif {- sparc_TARGET_ARCH -}
1549 %************************************************************************
1551 \subsection{Generating assignments}
1553 %************************************************************************
1555 Assignments are really at the heart of the whole code generation
1556 business. Almost all top-level nodes of any real importance are
1557 assignments, which correspond to loads, stores, or register transfers.
1558 If we're really lucky, some of the register transfers will go away,
1559 because we can use the destination register to complete the code
1560 generation for the right hand side. This only fails when the right
1561 hand side is forced into a fixed register (e.g. the result of a call).
1564 assignIntCode, assignFltCode
1565 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1567 #if alpha_TARGET_ARCH
1569 assignIntCode pk (StInd _ dst) src
1570 = getNewRegNCG IntRep `thenUs` \ tmp ->
1571 getAmode dst `thenUs` \ amode ->
1572 getRegister src `thenUs` \ register ->
1574 code1 = amodeCode amode asmVoid
1575 dst__2 = amodeAddr amode
1576 code2 = registerCode register tmp asmVoid
1577 src__2 = registerName register tmp
1578 sz = primRepToSize pk
1579 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1583 assignIntCode pk dst src
1584 = getRegister dst `thenUs` \ register1 ->
1585 getRegister src `thenUs` \ register2 ->
1587 dst__2 = registerName register1 zeroh
1588 code = registerCode register2 dst__2
1589 src__2 = registerName register2 dst__2
1590 code__2 = if isFixed register2
1591 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1596 #endif {- alpha_TARGET_ARCH -}
1597 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1598 #if i386_TARGET_ARCH
1600 assignIntCode pk (StInd _ dst) src
1601 = getAmode dst `thenUs` \ amode ->
1602 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1604 code1 = amodeCode amode asmVoid
1605 dst__2 = amodeAddr amode
1606 code__2 = asmParThen [code1, codesrc asmVoid] .
1607 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1613 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1617 = returnUs (asmParThen [], OpImm imm_op, L)
1620 imm_op = case imm of Just x -> x
1623 = getRegister op `thenUs` \ register ->
1624 getNewRegNCG (registerRep register)
1627 code = registerCode register tmp
1628 reg = registerName register tmp
1629 pk = registerRep register
1630 sz = primRepToSize pk
1632 returnUs (code, OpReg reg, sz)
1634 assignIntCode pk dst (StInd _ src)
1635 = getNewRegNCG IntRep `thenUs` \ tmp ->
1636 getAmode src `thenUs` \ amode ->
1637 getRegister dst `thenUs` \ register ->
1639 code1 = amodeCode amode asmVoid
1640 src__2 = amodeAddr amode
1641 code2 = registerCode register tmp asmVoid
1642 dst__2 = registerName register tmp
1643 sz = primRepToSize pk
1644 code__2 = asmParThen [code1, code2] .
1645 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1649 assignIntCode pk dst src
1650 = getRegister dst `thenUs` \ register1 ->
1651 getRegister src `thenUs` \ register2 ->
1652 getNewRegNCG IntRep `thenUs` \ tmp ->
1654 dst__2 = registerName register1 tmp
1655 code = registerCode register2 dst__2
1656 src__2 = registerName register2 dst__2
1657 code__2 = if isFixed register2 && dst__2 /= src__2
1658 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1663 #endif {- i386_TARGET_ARCH -}
1664 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1665 #if sparc_TARGET_ARCH
1667 assignIntCode pk (StInd _ dst) src
1668 = getNewRegNCG IntRep `thenUs` \ tmp ->
1669 getAmode dst `thenUs` \ amode ->
1670 getRegister src `thenUs` \ register ->
1672 code1 = amodeCode amode asmVoid
1673 dst__2 = amodeAddr amode
1674 code2 = registerCode register tmp asmVoid
1675 src__2 = registerName register tmp
1676 sz = primRepToSize pk
1677 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1681 assignIntCode pk dst src
1682 = getRegister dst `thenUs` \ register1 ->
1683 getRegister src `thenUs` \ register2 ->
1685 dst__2 = registerName register1 g0
1686 code = registerCode register2 dst__2
1687 src__2 = registerName register2 dst__2
1688 code__2 = if isFixed register2
1689 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1694 #endif {- sparc_TARGET_ARCH -}
1697 % --------------------------------
1698 Floating-point assignments:
1699 % --------------------------------
1701 #if alpha_TARGET_ARCH
1703 assignFltCode pk (StInd _ dst) src
1704 = getNewRegNCG pk `thenUs` \ tmp ->
1705 getAmode dst `thenUs` \ amode ->
1706 getRegister src `thenUs` \ register ->
1708 code1 = amodeCode amode asmVoid
1709 dst__2 = amodeAddr amode
1710 code2 = registerCode register tmp asmVoid
1711 src__2 = registerName register tmp
1712 sz = primRepToSize pk
1713 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1717 assignFltCode pk dst src
1718 = getRegister dst `thenUs` \ register1 ->
1719 getRegister src `thenUs` \ register2 ->
1721 dst__2 = registerName register1 zeroh
1722 code = registerCode register2 dst__2
1723 src__2 = registerName register2 dst__2
1724 code__2 = if isFixed register2
1725 then code . mkSeqInstr (FMOV src__2 dst__2)
1730 #endif {- alpha_TARGET_ARCH -}
1731 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1732 #if i386_TARGET_ARCH
1734 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1735 = getNewRegNCG IntRep `thenUs` \ tmp ->
1736 getAmode src `thenUs` \ amodesrc ->
1737 getAmode dst `thenUs` \ amodedst ->
1738 --getRegister src `thenUs` \ register ->
1740 codesrc1 = amodeCode amodesrc asmVoid
1741 addrsrc1 = amodeAddr amodesrc
1742 codedst1 = amodeCode amodedst asmVoid
1743 addrdst1 = amodeAddr amodedst
1744 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1745 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1747 code__2 = asmParThen [codesrc1, codedst1] .
1748 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1749 MOV L (OpReg tmp) (OpAddr addrdst1)]
1752 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1753 MOV L (OpReg tmp) (OpAddr addrdst2)]
1758 assignFltCode pk (StInd _ dst) src
1759 = --getNewRegNCG pk `thenUs` \ tmp ->
1760 getAmode dst `thenUs` \ amode ->
1761 getRegister src `thenUs` \ register ->
1763 sz = primRepToSize pk
1764 dst__2 = amodeAddr amode
1766 code1 = amodeCode amode asmVoid
1767 code2 = registerCode register {-tmp-}st0 asmVoid
1769 --src__2= registerName register tmp
1770 pk__2 = registerRep register
1771 sz__2 = primRepToSize pk__2
1773 code__2 = asmParThen [code1, code2] .
1774 mkSeqInstr (FSTP sz (OpAddr dst__2))
1778 assignFltCode pk dst src
1779 = getRegister dst `thenUs` \ register1 ->
1780 getRegister src `thenUs` \ register2 ->
1781 --getNewRegNCG (registerRep register2)
1782 -- `thenUs` \ tmp ->
1784 sz = primRepToSize pk
1785 dst__2 = registerName register1 st0 --tmp
1787 code = registerCode register2 dst__2
1788 src__2 = registerName register2 dst__2
1794 #endif {- i386_TARGET_ARCH -}
1795 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1796 #if sparc_TARGET_ARCH
1798 assignFltCode pk (StInd _ dst) src
1799 = getNewRegNCG pk `thenUs` \ tmp ->
1800 getAmode dst `thenUs` \ amode ->
1801 getRegister src `thenUs` \ register ->
1803 sz = primRepToSize pk
1804 dst__2 = amodeAddr amode
1806 code1 = amodeCode amode asmVoid
1807 code2 = registerCode register tmp asmVoid
1809 src__2 = registerName register tmp
1810 pk__2 = registerRep register
1811 sz__2 = primRepToSize pk__2
1813 code__2 = asmParThen [code1, code2] .
1815 mkSeqInstr (ST sz src__2 dst__2)
1817 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
1821 assignFltCode pk dst src
1822 = getRegister dst `thenUs` \ register1 ->
1823 getRegister src `thenUs` \ register2 ->
1824 getNewRegNCG (registerRep register2)
1827 sz = primRepToSize pk
1828 dst__2 = registerName register1 g0 -- must be Fixed
1830 reg__2 = if pk /= pk__2 then tmp else dst__2
1832 code = registerCode register2 reg__2
1833 src__2 = registerName register2 reg__2
1834 pk__2 = registerRep register2
1835 sz__2 = primRepToSize pk__2
1837 code__2 = if pk /= pk__2 then
1838 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1839 else if isFixed register2 then
1840 code . mkSeqInstr (FMOV sz src__2 dst__2)
1846 #endif {- sparc_TARGET_ARCH -}
1849 %************************************************************************
1851 \subsection{Generating an unconditional branch}
1853 %************************************************************************
1855 We accept two types of targets: an immediate CLabel or a tree that
1856 gets evaluated into a register. Any CLabels which are AsmTemporaries
1857 are assumed to be in the local block of code, close enough for a
1858 branch instruction. Other CLabels are assumed to be far away.
1860 (If applicable) Do not fill the delay slots here; you will confuse the
1864 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1866 #if alpha_TARGET_ARCH
1868 genJump (StCLbl lbl)
1869 | isAsmTemp lbl = returnInstr (BR target)
1870 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1872 target = ImmCLbl lbl
1875 = getRegister tree `thenUs` \ register ->
1876 getNewRegNCG PtrRep `thenUs` \ tmp ->
1878 dst = registerName register pv
1879 code = registerCode register pv
1880 target = registerName register pv
1882 if isFixed register then
1883 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1885 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1887 #endif {- alpha_TARGET_ARCH -}
1888 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1889 #if i386_TARGET_ARCH
1892 genJump (StCLbl lbl)
1893 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1894 | otherwise = returnInstrs [JMP (OpImm target)]
1896 target = ImmCLbl lbl
1899 genJump (StInd pk mem)
1900 = getAmode mem `thenUs` \ amode ->
1902 code = amodeCode amode
1903 target = amodeAddr amode
1905 returnSeq code [JMP (OpAddr target)]
1909 = returnInstr (JMP (OpImm target))
1912 = getRegister tree `thenUs` \ register ->
1913 getNewRegNCG PtrRep `thenUs` \ tmp ->
1915 code = registerCode register tmp
1916 target = registerName register tmp
1918 returnSeq code [JMP (OpReg target)]
1921 target = case imm of Just x -> x
1923 #endif {- i386_TARGET_ARCH -}
1924 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1925 #if sparc_TARGET_ARCH
1927 genJump (StCLbl lbl)
1928 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1929 | otherwise = returnInstrs [CALL target 0 True, NOP]
1931 target = ImmCLbl lbl
1934 = getRegister tree `thenUs` \ register ->
1935 getNewRegNCG PtrRep `thenUs` \ tmp ->
1937 code = registerCode register tmp
1938 target = registerName register tmp
1940 returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
1942 #endif {- sparc_TARGET_ARCH -}
1945 %************************************************************************
1947 \subsection{Conditional jumps}
1949 %************************************************************************
1951 Conditional jumps are always to local labels, so we can use branch
1952 instructions. We peek at the arguments to decide what kind of
1955 ALPHA: For comparisons with 0, we're laughing, because we can just do
1956 the desired conditional branch.
1958 I386: First, we have to ensure that the condition
1959 codes are set according to the supplied comparison operation.
1961 SPARC: First, we have to ensure that the condition codes are set
1962 according to the supplied comparison operation. We generate slightly
1963 different code for floating point comparisons, because a floating
1964 point operation cannot directly precede a @BF@. We assume the worst
1965 and fill that slot with a @NOP@.
1967 SPARC: Do not fill the delay slots here; you will confuse the register
1972 :: CLabel -- the branch target
1973 -> StixTree -- the condition on which to branch
1974 -> UniqSM InstrBlock
1976 #if alpha_TARGET_ARCH
1978 genCondJump lbl (StPrim op [x, StInt 0])
1979 = getRegister x `thenUs` \ register ->
1980 getNewRegNCG (registerRep register)
1983 code = registerCode register tmp
1984 value = registerName register tmp
1985 pk = registerRep register
1986 target = ImmCLbl lbl
1988 returnSeq code [BI (cmpOp op) value target]
1990 cmpOp CharGtOp = GTT
1992 cmpOp CharEqOp = EQQ
1994 cmpOp CharLtOp = LTT
2003 cmpOp WordGeOp = ALWAYS
2004 cmpOp WordEqOp = EQQ
2006 cmpOp WordLtOp = NEVER
2007 cmpOp WordLeOp = EQQ
2009 cmpOp AddrGeOp = ALWAYS
2010 cmpOp AddrEqOp = EQQ
2012 cmpOp AddrLtOp = NEVER
2013 cmpOp AddrLeOp = EQQ
2015 genCondJump lbl (StPrim op [x, StDouble 0.0])
2016 = getRegister x `thenUs` \ register ->
2017 getNewRegNCG (registerRep register)
2020 code = registerCode register tmp
2021 value = registerName register tmp
2022 pk = registerRep register
2023 target = ImmCLbl lbl
2025 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2027 cmpOp FloatGtOp = GTT
2028 cmpOp FloatGeOp = GE
2029 cmpOp FloatEqOp = EQQ
2030 cmpOp FloatNeOp = NE
2031 cmpOp FloatLtOp = LTT
2032 cmpOp FloatLeOp = LE
2033 cmpOp DoubleGtOp = GTT
2034 cmpOp DoubleGeOp = GE
2035 cmpOp DoubleEqOp = EQQ
2036 cmpOp DoubleNeOp = NE
2037 cmpOp DoubleLtOp = LTT
2038 cmpOp DoubleLeOp = LE
2040 genCondJump lbl (StPrim op [x, y])
2042 = trivialFCode pr instr x y `thenUs` \ register ->
2043 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2045 code = registerCode register tmp
2046 result = registerName register tmp
2047 target = ImmCLbl lbl
2049 returnUs (code . mkSeqInstr (BF cond result target))
2051 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2053 fltCmpOp op = case op of
2067 (instr, cond) = case op of
2068 FloatGtOp -> (FCMP TF LE, EQQ)
2069 FloatGeOp -> (FCMP TF LTT, EQQ)
2070 FloatEqOp -> (FCMP TF EQQ, NE)
2071 FloatNeOp -> (FCMP TF EQQ, EQQ)
2072 FloatLtOp -> (FCMP TF LTT, NE)
2073 FloatLeOp -> (FCMP TF LE, NE)
2074 DoubleGtOp -> (FCMP TF LE, EQQ)
2075 DoubleGeOp -> (FCMP TF LTT, EQQ)
2076 DoubleEqOp -> (FCMP TF EQQ, NE)
2077 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2078 DoubleLtOp -> (FCMP TF LTT, NE)
2079 DoubleLeOp -> (FCMP TF LE, NE)
2081 genCondJump lbl (StPrim op [x, y])
2082 = trivialCode instr x y `thenUs` \ register ->
2083 getNewRegNCG IntRep `thenUs` \ tmp ->
2085 code = registerCode register tmp
2086 result = registerName register tmp
2087 target = ImmCLbl lbl
2089 returnUs (code . mkSeqInstr (BI cond result target))
2091 (instr, cond) = case op of
2092 CharGtOp -> (CMP LE, EQQ)
2093 CharGeOp -> (CMP LTT, EQQ)
2094 CharEqOp -> (CMP EQQ, NE)
2095 CharNeOp -> (CMP EQQ, EQQ)
2096 CharLtOp -> (CMP LTT, NE)
2097 CharLeOp -> (CMP LE, NE)
2098 IntGtOp -> (CMP LE, EQQ)
2099 IntGeOp -> (CMP LTT, EQQ)
2100 IntEqOp -> (CMP EQQ, NE)
2101 IntNeOp -> (CMP EQQ, EQQ)
2102 IntLtOp -> (CMP LTT, NE)
2103 IntLeOp -> (CMP LE, NE)
2104 WordGtOp -> (CMP ULE, EQQ)
2105 WordGeOp -> (CMP ULT, EQQ)
2106 WordEqOp -> (CMP EQQ, NE)
2107 WordNeOp -> (CMP EQQ, EQQ)
2108 WordLtOp -> (CMP ULT, NE)
2109 WordLeOp -> (CMP ULE, NE)
2110 AddrGtOp -> (CMP ULE, EQQ)
2111 AddrGeOp -> (CMP ULT, EQQ)
2112 AddrEqOp -> (CMP EQQ, NE)
2113 AddrNeOp -> (CMP EQQ, EQQ)
2114 AddrLtOp -> (CMP ULT, NE)
2115 AddrLeOp -> (CMP ULE, NE)
2117 #endif {- alpha_TARGET_ARCH -}
2118 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2119 #if i386_TARGET_ARCH
2121 genCondJump lbl bool
2122 = getCondCode bool `thenUs` \ condition ->
2124 code = condCode condition
2125 cond = condName condition
2126 target = ImmCLbl lbl
2128 returnSeq code [JXX cond lbl]
2130 #endif {- i386_TARGET_ARCH -}
2131 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2132 #if sparc_TARGET_ARCH
2134 genCondJump lbl bool
2135 = getCondCode bool `thenUs` \ condition ->
2137 code = condCode condition
2138 cond = condName condition
2139 target = ImmCLbl lbl
2142 if condFloat condition then
2143 [NOP, BF cond False target, NOP]
2145 [BI cond False target, NOP]
2148 #endif {- sparc_TARGET_ARCH -}
2151 %************************************************************************
2153 \subsection{Generating C calls}
2155 %************************************************************************
2157 Now the biggest nightmare---calls. Most of the nastiness is buried in
2158 @get_arg@, which moves the arguments to the correct registers/stack
2159 locations. Apart from that, the code is easy.
2161 (If applicable) Do not fill the delay slots here; you will confuse the
2166 :: FAST_STRING -- function to call
2167 -> PrimRep -- type of the result
2168 -> [StixTree] -- arguments (of mixed type)
2169 -> UniqSM InstrBlock
2171 #if alpha_TARGET_ARCH
2173 genCCall fn kind args
2174 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2175 `thenUs` \ ((unused,_), argCode) ->
2177 nRegs = length allArgRegs - length unused
2178 code = asmParThen (map ($ asmVoid) argCode)
2181 LDA pv (AddrImm (ImmLab (ptext fn))),
2182 JSR ra (AddrReg pv) nRegs,
2183 LDGP gp (AddrReg ra)]
2185 ------------------------
2186 {- Try to get a value into a specific register (or registers) for
2187 a call. The first 6 arguments go into the appropriate
2188 argument register (separate registers for integer and floating
2189 point arguments, but used in lock-step), and the remaining
2190 arguments are dumped to the stack, beginning at 0(sp). Our
2191 first argument is a pair of the list of remaining argument
2192 registers to be assigned for this call and the next stack
2193 offset to use for overflowing arguments. This way,
2194 @get_Arg@ can be applied to all of a call's arguments using
2198 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2199 -> StixTree -- Current argument
2200 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2202 -- We have to use up all of our argument registers first...
2204 get_arg ((iDst,fDst):dsts, offset) arg
2205 = getRegister arg `thenUs` \ register ->
2207 reg = if isFloatingRep pk then fDst else iDst
2208 code = registerCode register reg
2209 src = registerName register reg
2210 pk = registerRep register
2213 if isFloatingRep pk then
2214 ((dsts, offset), if isFixed register then
2215 code . mkSeqInstr (FMOV src fDst)
2218 ((dsts, offset), if isFixed register then
2219 code . mkSeqInstr (OR src (RIReg src) iDst)
2222 -- Once we have run out of argument registers, we move to the
2225 get_arg ([], offset) arg
2226 = getRegister arg `thenUs` \ register ->
2227 getNewRegNCG (registerRep register)
2230 code = registerCode register tmp
2231 src = registerName register tmp
2232 pk = registerRep register
2233 sz = primRepToSize pk
2235 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2237 #endif {- alpha_TARGET_ARCH -}
2238 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2239 #if i386_TARGET_ARCH
2241 genCCall fn kind [StInt i]
2242 | fn == SLIT ("PerformGC_wrapper")
2243 = getUniqLabelNCG `thenUs` \ lbl ->
2245 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2246 MOV L (OpImm (ImmCLbl lbl))
2247 -- this is hardwired
2248 (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
2249 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2254 genCCall fn kind args
2255 = mapUs get_call_arg args `thenUs` \ argCode ->
2258 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
2259 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2262 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2263 call = [CALL fn__2 -- ,
2264 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
2265 -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2268 returnSeq (code1 . code2) call
2270 -- function names that begin with '.' are assumed to be special
2271 -- internally generated names like '.mul,' which don't get an
2272 -- underscore prefix
2273 -- ToDo:needed (WDP 96/03) ???
2274 fn__2 = case (_HEAD_ fn) of
2275 '.' -> ImmLit (ptext fn)
2276 _ -> ImmLab (ptext fn)
2279 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2282 = get_op arg `thenUs` \ (code, op, sz) ->
2283 returnUs (code . mkSeqInstr (PUSH sz op))
2288 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2291 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2293 get_op (StInd pk mem)
2294 = getAmode mem `thenUs` \ amode ->
2296 code = amodeCode amode --asmVoid
2297 addr = amodeAddr amode
2298 sz = primRepToSize pk
2300 returnUs (code, OpAddr addr, sz)
2303 = getRegister op `thenUs` \ register ->
2304 getNewRegNCG (registerRep register)
2307 code = registerCode register tmp
2308 reg = registerName register tmp
2309 pk = registerRep register
2310 sz = primRepToSize pk
2312 returnUs (code, OpReg reg, sz)
2314 #endif {- i386_TARGET_ARCH -}
2315 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2316 #if sparc_TARGET_ARCH
2318 genCCall fn kind args
2319 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2320 `thenUs` \ ((unused,_), argCode) ->
2322 nRegs = length allArgRegs - length unused
2323 call = CALL fn__2 nRegs False
2324 code = asmParThen (map ($ asmVoid) argCode)
2326 returnSeq code [call, NOP]
2328 -- function names that begin with '.' are assumed to be special
2329 -- internally generated names like '.mul,' which don't get an
2330 -- underscore prefix
2331 -- ToDo:needed (WDP 96/03) ???
2332 fn__2 = case (_HEAD_ fn) of
2333 '.' -> ImmLit (ptext fn)
2334 _ -> ImmLab (ptext fn)
2336 ------------------------------------
2337 {- Try to get a value into a specific register (or registers) for
2338 a call. The SPARC calling convention is an absolute
2339 nightmare. The first 6x32 bits of arguments are mapped into
2340 %o0 through %o5, and the remaining arguments are dumped to the
2341 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2342 first argument is a pair of the list of remaining argument
2343 registers to be assigned for this call and the next stack
2344 offset to use for overflowing arguments. This way,
2345 @get_arg@ can be applied to all of a call's arguments using
2349 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2350 -> StixTree -- Current argument
2351 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2353 -- We have to use up all of our argument registers first...
2355 get_arg (dst:dsts, offset) arg
2356 = getRegister arg `thenUs` \ register ->
2357 getNewRegNCG (registerRep register)
2360 reg = if isFloatingRep pk then tmp else dst
2361 code = registerCode register reg
2362 src = registerName register reg
2363 pk = registerRep register
2365 returnUs (case pk of
2368 [] -> (([], offset + 1), code . mkSeqInstrs [
2369 -- conveniently put the second part in the right stack
2370 -- location, and load the first part into %o5
2371 ST DF src (spRel (offset - 1)),
2372 LD W (spRel (offset - 1)) dst])
2373 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2374 ST DF src (spRel (-2)),
2375 LD W (spRel (-2)) dst,
2376 LD W (spRel (-1)) dst__2])
2377 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2378 ST F src (spRel (-2)),
2379 LD W (spRel (-2)) dst])
2380 _ -> ((dsts, offset), if isFixed register then
2381 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2384 -- Once we have run out of argument registers, we move to the
2387 get_arg ([], offset) arg
2388 = getRegister arg `thenUs` \ register ->
2389 getNewRegNCG (registerRep register)
2392 code = registerCode register tmp
2393 src = registerName register tmp
2394 pk = registerRep register
2395 sz = primRepToSize pk
2396 words = if pk == DoubleRep then 2 else 1
2398 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2400 #endif {- sparc_TARGET_ARCH -}
2403 %************************************************************************
2405 \subsection{Support bits}
2407 %************************************************************************
2409 %************************************************************************
2411 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2413 %************************************************************************
2415 Turn those condition codes into integers now (when they appear on
2416 the right hand side of an assignment).
2418 (If applicable) Do not fill the delay slots here; you will confuse the
2422 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2424 #if alpha_TARGET_ARCH
2425 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2426 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2427 #endif {- alpha_TARGET_ARCH -}
2429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2430 #if i386_TARGET_ARCH
2433 = condIntCode cond x y `thenUs` \ condition ->
2434 getNewRegNCG IntRep `thenUs` \ tmp ->
2435 --getRegister dst `thenUs` \ register ->
2437 --code2 = registerCode register tmp asmVoid
2438 --dst__2 = registerName register tmp
2439 code = condCode condition
2440 cond = condName condition
2441 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2442 code__2 dst = code . mkSeqInstrs [
2443 SETCC cond (OpReg tmp),
2444 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2445 MOV L (OpReg tmp) (OpReg dst)]
2447 returnUs (Any IntRep code__2)
2450 = getUniqLabelNCG `thenUs` \ lbl1 ->
2451 getUniqLabelNCG `thenUs` \ lbl2 ->
2452 condFltCode cond x y `thenUs` \ condition ->
2454 code = condCode condition
2455 cond = condName condition
2456 code__2 dst = code . mkSeqInstrs [
2458 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2461 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2464 returnUs (Any IntRep code__2)
2466 #endif {- i386_TARGET_ARCH -}
2467 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2468 #if sparc_TARGET_ARCH
2470 condIntReg EQQ x (StInt 0)
2471 = getRegister x `thenUs` \ register ->
2472 getNewRegNCG IntRep `thenUs` \ tmp ->
2474 code = registerCode register tmp
2475 src = registerName register tmp
2476 code__2 dst = code . mkSeqInstrs [
2477 SUB False True g0 (RIReg src) g0,
2478 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2480 returnUs (Any IntRep code__2)
2483 = getRegister x `thenUs` \ register1 ->
2484 getRegister y `thenUs` \ register2 ->
2485 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2486 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2488 code1 = registerCode register1 tmp1 asmVoid
2489 src1 = registerName register1 tmp1
2490 code2 = registerCode register2 tmp2 asmVoid
2491 src2 = registerName register2 tmp2
2492 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2493 XOR False src1 (RIReg src2) dst,
2494 SUB False True g0 (RIReg dst) g0,
2495 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2497 returnUs (Any IntRep code__2)
2499 condIntReg NE x (StInt 0)
2500 = getRegister x `thenUs` \ register ->
2501 getNewRegNCG IntRep `thenUs` \ tmp ->
2503 code = registerCode register tmp
2504 src = registerName register tmp
2505 code__2 dst = code . mkSeqInstrs [
2506 SUB False True g0 (RIReg src) g0,
2507 ADD True False g0 (RIImm (ImmInt 0)) dst]
2509 returnUs (Any IntRep code__2)
2512 = getRegister x `thenUs` \ register1 ->
2513 getRegister y `thenUs` \ register2 ->
2514 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2515 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2517 code1 = registerCode register1 tmp1 asmVoid
2518 src1 = registerName register1 tmp1
2519 code2 = registerCode register2 tmp2 asmVoid
2520 src2 = registerName register2 tmp2
2521 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2522 XOR False src1 (RIReg src2) dst,
2523 SUB False True g0 (RIReg dst) g0,
2524 ADD True False g0 (RIImm (ImmInt 0)) dst]
2526 returnUs (Any IntRep code__2)
2529 = getUniqLabelNCG `thenUs` \ lbl1 ->
2530 getUniqLabelNCG `thenUs` \ lbl2 ->
2531 condIntCode cond x y `thenUs` \ condition ->
2533 code = condCode condition
2534 cond = condName condition
2535 code__2 dst = code . mkSeqInstrs [
2536 BI cond False (ImmCLbl lbl1), NOP,
2537 OR False g0 (RIImm (ImmInt 0)) dst,
2538 BI ALWAYS False (ImmCLbl lbl2), NOP,
2540 OR False g0 (RIImm (ImmInt 1)) dst,
2543 returnUs (Any IntRep code__2)
2546 = getUniqLabelNCG `thenUs` \ lbl1 ->
2547 getUniqLabelNCG `thenUs` \ lbl2 ->
2548 condFltCode cond x y `thenUs` \ condition ->
2550 code = condCode condition
2551 cond = condName condition
2552 code__2 dst = code . mkSeqInstrs [
2554 BF cond False (ImmCLbl lbl1), NOP,
2555 OR False g0 (RIImm (ImmInt 0)) dst,
2556 BI ALWAYS False (ImmCLbl lbl2), NOP,
2558 OR False g0 (RIImm (ImmInt 1)) dst,
2561 returnUs (Any IntRep code__2)
2563 #endif {- sparc_TARGET_ARCH -}
2566 %************************************************************************
2568 \subsubsection{@trivial*Code@: deal with trivial instructions}
2570 %************************************************************************
2572 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2573 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2574 for constants on the right hand side, because that's where the generic
2575 optimizer will have put them.
2577 Similarly, for unary instructions, we don't have to worry about
2578 matching an StInt as the argument, because genericOpt will already
2579 have handled the constant-folding.
2583 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2584 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2585 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2587 -> StixTree -> StixTree -- the two arguments
2592 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2593 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2595 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2596 (Size -> Operand -> Instr)
2597 -> (Size -> Operand -> Instr) {-reversed instr-}
2599 -> Instr {-reversed instr: pop-}
2601 -> StixTree -> StixTree -- the two arguments
2605 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2606 ,IF_ARCH_i386 ((Operand -> Instr)
2607 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2609 -> StixTree -- the one argument
2614 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2615 ,IF_ARCH_i386 (Instr
2616 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2618 -> StixTree -- the one argument
2621 #if alpha_TARGET_ARCH
2623 trivialCode instr x (StInt y)
2625 = getRegister x `thenUs` \ register ->
2626 getNewRegNCG IntRep `thenUs` \ tmp ->
2628 code = registerCode register tmp
2629 src1 = registerName register tmp
2630 src2 = ImmInt (fromInteger y)
2631 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2633 returnUs (Any IntRep code__2)
2635 trivialCode instr x y
2636 = getRegister x `thenUs` \ register1 ->
2637 getRegister y `thenUs` \ register2 ->
2638 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2639 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2641 code1 = registerCode register1 tmp1 asmVoid
2642 src1 = registerName register1 tmp1
2643 code2 = registerCode register2 tmp2 asmVoid
2644 src2 = registerName register2 tmp2
2645 code__2 dst = asmParThen [code1, code2] .
2646 mkSeqInstr (instr src1 (RIReg src2) dst)
2648 returnUs (Any IntRep code__2)
2651 trivialUCode instr x
2652 = getRegister x `thenUs` \ register ->
2653 getNewRegNCG IntRep `thenUs` \ tmp ->
2655 code = registerCode register tmp
2656 src = registerName register tmp
2657 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2659 returnUs (Any IntRep code__2)
2662 trivialFCode _ instr x y
2663 = getRegister x `thenUs` \ register1 ->
2664 getRegister y `thenUs` \ register2 ->
2665 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2666 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2668 code1 = registerCode register1 tmp1
2669 src1 = registerName register1 tmp1
2671 code2 = registerCode register2 tmp2
2672 src2 = registerName register2 tmp2
2674 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2675 mkSeqInstr (instr src1 src2 dst)
2677 returnUs (Any DoubleRep code__2)
2679 trivialUFCode _ instr x
2680 = getRegister x `thenUs` \ register ->
2681 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2683 code = registerCode register tmp
2684 src = registerName register tmp
2685 code__2 dst = code . mkSeqInstr (instr src dst)
2687 returnUs (Any DoubleRep code__2)
2689 #endif {- alpha_TARGET_ARCH -}
2690 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2691 #if i386_TARGET_ARCH
2693 trivialCode instr x y
2695 = getRegister x `thenUs` \ register1 ->
2696 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2698 fixedname = registerName register1 eax
2699 code__2 dst = let code1 = registerCode register1 dst
2700 src1 = registerName register1 dst
2702 if isFixed register1 && src1 /= dst
2703 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2704 instr (OpImm imm__2) (OpReg dst)]
2706 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2708 returnUs (Any IntRep code__2)
2711 imm__2 = case imm of Just x -> x
2713 trivialCode instr x y
2715 = getRegister y `thenUs` \ register1 ->
2716 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2718 fixedname = registerName register1 eax
2719 code__2 dst = let code1 = registerCode register1 dst
2720 src1 = registerName register1 dst
2722 if isFixed register1 && src1 /= dst
2723 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2724 instr (OpImm imm__2) (OpReg dst)]
2726 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2728 returnUs (Any IntRep code__2)
2731 imm__2 = case imm of Just x -> x
2733 trivialCode instr x (StInd pk mem)
2734 = getRegister x `thenUs` \ register ->
2735 --getNewRegNCG IntRep `thenUs` \ tmp ->
2736 getAmode mem `thenUs` \ amode ->
2738 fixedname = registerName register eax
2739 code2 = amodeCode amode asmVoid
2740 src2 = amodeAddr amode
2741 code__2 dst = let code1 = registerCode register dst asmVoid
2742 src1 = registerName register dst
2743 in asmParThen [code1, code2] .
2744 if isFixed register && src1 /= dst
2745 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2746 instr (OpAddr src2) (OpReg dst)]
2748 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2750 returnUs (Any pk code__2)
2752 trivialCode instr (StInd pk mem) y
2753 = getRegister y `thenUs` \ register ->
2754 --getNewRegNCG IntRep `thenUs` \ tmp ->
2755 getAmode mem `thenUs` \ amode ->
2757 fixedname = registerName register eax
2758 code2 = amodeCode amode asmVoid
2759 src2 = amodeAddr amode
2761 code1 = registerCode register dst asmVoid
2762 src1 = registerName register dst
2763 in asmParThen [code1, code2] .
2764 if isFixed register && src1 /= dst
2765 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2766 instr (OpAddr src2) (OpReg dst)]
2768 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2770 returnUs (Any pk code__2)
2772 trivialCode instr x y
2773 = getRegister x `thenUs` \ register1 ->
2774 getRegister y `thenUs` \ register2 ->
2775 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2776 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2778 fixedname = registerName register1 eax
2779 code2 = registerCode register2 tmp2 asmVoid
2780 src2 = registerName register2 tmp2
2782 code1 = registerCode register1 dst asmVoid
2783 src1 = registerName register1 dst
2784 in asmParThen [code1, code2] .
2785 if isFixed register1 && src1 /= dst
2786 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2787 instr (OpReg src2) (OpReg dst)]
2789 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2791 returnUs (Any IntRep code__2)
2794 trivialUCode instr x
2795 = getRegister x `thenUs` \ register ->
2796 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2798 -- fixedname = registerName register eax
2800 code = registerCode register dst
2801 src = registerName register dst
2802 in code . if isFixed register && dst /= src
2803 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2805 else mkSeqInstr (instr (OpReg src))
2807 returnUs (Any IntRep code__2)
2810 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2811 = getRegister y `thenUs` \ register2 ->
2812 --getNewRegNCG (registerRep register2)
2813 -- `thenUs` \ tmp2 ->
2814 getAmode mem `thenUs` \ amode ->
2816 code1 = amodeCode amode
2817 src1 = amodeAddr amode
2820 code2 = registerCode register2 dst
2821 src2 = registerName register2 dst
2822 in asmParThen [code1 asmVoid,code2 asmVoid] .
2823 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2825 returnUs (Any pk code__2)
2827 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2828 = getRegister x `thenUs` \ register1 ->
2829 --getNewRegNCG (registerRep register1)
2830 -- `thenUs` \ tmp1 ->
2831 getAmode mem `thenUs` \ amode ->
2833 code2 = amodeCode amode
2834 src2 = amodeAddr amode
2837 code1 = registerCode register1 dst
2838 src1 = registerName register1 dst
2839 in asmParThen [code2 asmVoid,code1 asmVoid] .
2840 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2842 returnUs (Any pk code__2)
2844 trivialFCode pk _ _ _ instrpr x y
2845 = getRegister x `thenUs` \ register1 ->
2846 getRegister y `thenUs` \ register2 ->
2847 --getNewRegNCG (registerRep register1)
2848 -- `thenUs` \ tmp1 ->
2849 --getNewRegNCG (registerRep register2)
2850 -- `thenUs` \ tmp2 ->
2851 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2853 pk1 = registerRep register1
2854 code1 = registerCode register1 st0 --tmp1
2855 src1 = registerName register1 st0 --tmp1
2857 pk2 = registerRep register2
2860 code2 = registerCode register2 dst
2861 src2 = registerName register2 dst
2862 in asmParThen [code1 asmVoid, code2 asmVoid] .
2865 returnUs (Any pk1 code__2)
2868 trivialUFCode pk instr (StInd pk' mem)
2869 = getAmode mem `thenUs` \ amode ->
2871 code = amodeCode amode
2872 src = amodeAddr amode
2873 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2876 returnUs (Any pk code__2)
2878 trivialUFCode pk instr x
2879 = getRegister x `thenUs` \ register ->
2880 --getNewRegNCG pk `thenUs` \ tmp ->
2883 code = registerCode register dst
2884 src = registerName register dst
2885 in code . mkSeqInstrs [instr]
2887 returnUs (Any pk code__2)
2889 #endif {- i386_TARGET_ARCH -}
2890 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2891 #if sparc_TARGET_ARCH
2893 trivialCode instr x (StInt y)
2895 = getRegister x `thenUs` \ register ->
2896 getNewRegNCG IntRep `thenUs` \ tmp ->
2898 code = registerCode register tmp
2899 src1 = registerName register tmp
2900 src2 = ImmInt (fromInteger y)
2901 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2903 returnUs (Any IntRep code__2)
2905 trivialCode instr x y
2906 = getRegister x `thenUs` \ register1 ->
2907 getRegister y `thenUs` \ register2 ->
2908 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2909 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2911 code1 = registerCode register1 tmp1 asmVoid
2912 src1 = registerName register1 tmp1
2913 code2 = registerCode register2 tmp2 asmVoid
2914 src2 = registerName register2 tmp2
2915 code__2 dst = asmParThen [code1, code2] .
2916 mkSeqInstr (instr src1 (RIReg src2) dst)
2918 returnUs (Any IntRep code__2)
2921 trivialFCode pk instr x y
2922 = getRegister x `thenUs` \ register1 ->
2923 getRegister y `thenUs` \ register2 ->
2924 getNewRegNCG (registerRep register1)
2926 getNewRegNCG (registerRep register2)
2928 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2930 promote x = asmInstr (FxTOy F DF x tmp)
2932 pk1 = registerRep register1
2933 code1 = registerCode register1 tmp1
2934 src1 = registerName register1 tmp1
2936 pk2 = registerRep register2
2937 code2 = registerCode register2 tmp2
2938 src2 = registerName register2 tmp2
2942 asmParThen [code1 asmVoid, code2 asmVoid] .
2943 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2944 else if pk1 == FloatRep then
2945 asmParThen [code1 (promote src1), code2 asmVoid] .
2946 mkSeqInstr (instr DF tmp src2 dst)
2948 asmParThen [code1 asmVoid, code2 (promote src2)] .
2949 mkSeqInstr (instr DF src1 tmp dst)
2951 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2954 trivialUCode instr x
2955 = getRegister x `thenUs` \ register ->
2956 getNewRegNCG IntRep `thenUs` \ tmp ->
2958 code = registerCode register tmp
2959 src = registerName register tmp
2960 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2962 returnUs (Any IntRep code__2)
2965 trivialUFCode pk instr x
2966 = getRegister x `thenUs` \ register ->
2967 getNewRegNCG pk `thenUs` \ tmp ->
2969 code = registerCode register tmp
2970 src = registerName register tmp
2971 code__2 dst = code . mkSeqInstr (instr src dst)
2973 returnUs (Any pk code__2)
2975 #endif {- sparc_TARGET_ARCH -}
2978 %************************************************************************
2980 \subsubsection{Coercing to/from integer/floating-point...}
2982 %************************************************************************
2984 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2985 to be generated. Here we just change the type on the Register passed
2986 on up. The code is machine-independent.
2988 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2989 conversions. We have to store temporaries in memory to move
2990 between the integer and the floating point register sets.
2993 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2994 coerceFltCode :: StixTree -> UniqSM Register
2996 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
2997 coerceFP2Int :: StixTree -> UniqSM Register
3000 = getRegister x `thenUs` \ register ->
3003 Fixed _ reg code -> Fixed pk reg code
3004 Any _ code -> Any pk code
3009 = getRegister x `thenUs` \ register ->
3012 Fixed _ reg code -> Fixed DoubleRep reg code
3013 Any _ code -> Any DoubleRep code
3018 #if alpha_TARGET_ARCH
3021 = getRegister x `thenUs` \ register ->
3022 getNewRegNCG IntRep `thenUs` \ reg ->
3024 code = registerCode register reg
3025 src = registerName register reg
3027 code__2 dst = code . mkSeqInstrs [
3029 LD TF dst (spRel 0),
3032 returnUs (Any DoubleRep code__2)
3036 = getRegister x `thenUs` \ register ->
3037 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3039 code = registerCode register tmp
3040 src = registerName register tmp
3042 code__2 dst = code . mkSeqInstrs [
3044 ST TF tmp (spRel 0),
3047 returnUs (Any IntRep code__2)
3049 #endif {- alpha_TARGET_ARCH -}
3050 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3051 #if i386_TARGET_ARCH
3054 = getRegister x `thenUs` \ register ->
3055 getNewRegNCG IntRep `thenUs` \ reg ->
3057 code = registerCode register reg
3058 src = registerName register reg
3060 code__2 dst = code . mkSeqInstrs [
3061 -- to fix: should spill instead of using R1
3062 MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
3063 FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3065 returnUs (Any pk code__2)
3069 = getRegister x `thenUs` \ register ->
3070 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3072 code = registerCode register tmp
3073 src = registerName register tmp
3074 pk = registerRep register
3077 in code . mkSeqInstrs [
3079 FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
3080 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3082 returnUs (Any IntRep code__2)
3084 #endif {- i386_TARGET_ARCH -}
3085 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3086 #if sparc_TARGET_ARCH
3089 = getRegister x `thenUs` \ register ->
3090 getNewRegNCG IntRep `thenUs` \ reg ->
3092 code = registerCode register reg
3093 src = registerName register reg
3095 code__2 dst = code . mkSeqInstrs [
3096 ST W src (spRel (-2)),
3097 LD W (spRel (-2)) dst,
3098 FxTOy W (primRepToSize pk) dst dst]
3100 returnUs (Any pk code__2)
3104 = getRegister x `thenUs` \ register ->
3105 getNewRegNCG IntRep `thenUs` \ reg ->
3106 getNewRegNCG FloatRep `thenUs` \ tmp ->
3108 code = registerCode register reg
3109 src = registerName register reg
3110 pk = registerRep register
3112 code__2 dst = code . mkSeqInstrs [
3113 FxTOy (primRepToSize pk) W src tmp,
3114 ST W tmp (spRel (-2)),
3115 LD W (spRel (-2)) dst]
3117 returnUs (Any IntRep code__2)
3119 #endif {- sparc_TARGET_ARCH -}
3122 %************************************************************************
3124 \subsubsection{Coercing integer to @Char@...}
3126 %************************************************************************
3128 Integer to character conversion. Where applicable, we try to do this
3129 in one step if the original object is in memory.
3132 chrCode :: StixTree -> UniqSM Register
3134 #if alpha_TARGET_ARCH
3137 = getRegister x `thenUs` \ register ->
3138 getNewRegNCG IntRep `thenUs` \ reg ->
3140 code = registerCode register reg
3141 src = registerName register reg
3142 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3144 returnUs (Any IntRep code__2)
3146 #endif {- alpha_TARGET_ARCH -}
3147 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3148 #if i386_TARGET_ARCH
3151 = getRegister x `thenUs` \ register ->
3152 --getNewRegNCG IntRep `thenUs` \ reg ->
3154 fixedname = registerName register eax
3156 code = registerCode register dst
3157 src = registerName register dst
3159 if isFixed register && src /= dst
3160 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3161 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3162 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3164 returnUs (Any IntRep code__2)
3166 #endif {- i386_TARGET_ARCH -}
3167 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3168 #if sparc_TARGET_ARCH
3170 chrCode (StInd pk mem)
3171 = getAmode mem `thenUs` \ amode ->
3173 code = amodeCode amode
3174 src = amodeAddr amode
3175 src_off = addrOffset src 3
3176 src__2 = case src_off of Just x -> x
3177 code__2 dst = if maybeToBool src_off then
3178 code . mkSeqInstr (LD BU src__2 dst)
3180 code . mkSeqInstrs [
3181 LD (primRepToSize pk) src dst,
3182 AND False dst (RIImm (ImmInt 255)) dst]
3184 returnUs (Any pk code__2)
3187 = getRegister x `thenUs` \ register ->
3188 getNewRegNCG IntRep `thenUs` \ reg ->
3190 code = registerCode register reg
3191 src = registerName register reg
3192 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3194 returnUs (Any IntRep code__2)
3196 #endif {- sparc_TARGET_ARCH -}
3199 %************************************************************************
3201 \subsubsection{Absolute value on integers}
3203 %************************************************************************
3205 Absolute value on integers, mostly for gmp size check macros. Again,
3206 the argument cannot be an StInt, because genericOpt already folded
3209 If applicable, do not fill the delay slots here; you will confuse the
3213 absIntCode :: StixTree -> UniqSM Register
3215 #if alpha_TARGET_ARCH
3216 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3217 #endif {- alpha_TARGET_ARCH -}
3219 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3220 #if i386_TARGET_ARCH
3223 = getRegister x `thenUs` \ register ->
3224 --getNewRegNCG IntRep `thenUs` \ reg ->
3225 getUniqLabelNCG `thenUs` \ lbl ->
3227 code__2 dst = let code = registerCode register dst
3228 src = registerName register dst
3229 in code . if isFixed register && dst /= src
3230 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3231 TEST L (OpReg dst) (OpReg dst),
3235 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3240 returnUs (Any IntRep code__2)
3242 #endif {- i386_TARGET_ARCH -}
3243 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3244 #if sparc_TARGET_ARCH
3247 = getRegister x `thenUs` \ register ->
3248 getNewRegNCG IntRep `thenUs` \ reg ->
3249 getUniqLabelNCG `thenUs` \ lbl ->
3251 code = registerCode register reg
3252 src = registerName register reg
3253 code__2 dst = code . mkSeqInstrs [
3254 SUB False True g0 (RIReg src) dst,
3255 BI GE False (ImmCLbl lbl), NOP,
3256 OR False g0 (RIReg src) dst,
3259 returnUs (Any IntRep code__2)
3261 #endif {- sparc_TARGET_ARCH -}