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]
153 shift DoubleRep = 3::Integer
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` \ tmp1 ->
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 tmp1 asmVoid
1809 src__2 = registerName register tmp1
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 tmp1, ST sz tmp1 dst__2]
1821 assignFltCode pk dst src
1822 = getRegister dst `thenUs` \ register1 ->
1823 getRegister src `thenUs` \ register2 ->
1825 pk__2 = registerRep register2
1826 sz__2 = primRepToSize pk__2
1828 getNewRegNCG pk__2 `thenUs` \ tmp ->
1830 sz = primRepToSize pk
1831 dst__2 = registerName register1 g0 -- must be Fixed
1834 reg__2 = if pk /= pk__2 then tmp else dst__2
1836 code = registerCode register2 reg__2
1838 src__2 = registerName register2 reg__2
1842 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1843 else if isFixed register2 then
1844 code . mkSeqInstr (FMOV sz src__2 dst__2)
1850 #endif {- sparc_TARGET_ARCH -}
1853 %************************************************************************
1855 \subsection{Generating an unconditional branch}
1857 %************************************************************************
1859 We accept two types of targets: an immediate CLabel or a tree that
1860 gets evaluated into a register. Any CLabels which are AsmTemporaries
1861 are assumed to be in the local block of code, close enough for a
1862 branch instruction. Other CLabels are assumed to be far away.
1864 (If applicable) Do not fill the delay slots here; you will confuse the
1868 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1870 #if alpha_TARGET_ARCH
1872 genJump (StCLbl lbl)
1873 | isAsmTemp lbl = returnInstr (BR target)
1874 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1876 target = ImmCLbl lbl
1879 = getRegister tree `thenUs` \ register ->
1880 getNewRegNCG PtrRep `thenUs` \ tmp ->
1882 dst = registerName register pv
1883 code = registerCode register pv
1884 target = registerName register pv
1886 if isFixed register then
1887 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1889 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1891 #endif {- alpha_TARGET_ARCH -}
1892 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1893 #if i386_TARGET_ARCH
1896 genJump (StCLbl lbl)
1897 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1898 | otherwise = returnInstrs [JMP (OpImm target)]
1900 target = ImmCLbl lbl
1903 genJump (StInd pk mem)
1904 = getAmode mem `thenUs` \ amode ->
1906 code = amodeCode amode
1907 target = amodeAddr amode
1909 returnSeq code [JMP (OpAddr target)]
1913 = returnInstr (JMP (OpImm target))
1916 = getRegister tree `thenUs` \ register ->
1917 getNewRegNCG PtrRep `thenUs` \ tmp ->
1919 code = registerCode register tmp
1920 target = registerName register tmp
1922 returnSeq code [JMP (OpReg target)]
1925 target = case imm of Just x -> x
1927 #endif {- i386_TARGET_ARCH -}
1928 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1929 #if sparc_TARGET_ARCH
1931 genJump (StCLbl lbl)
1932 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1933 | otherwise = returnInstrs [CALL target 0 True, NOP]
1935 target = ImmCLbl lbl
1938 = getRegister tree `thenUs` \ register ->
1939 getNewRegNCG PtrRep `thenUs` \ tmp ->
1941 code = registerCode register tmp
1942 target = registerName register tmp
1944 returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
1946 #endif {- sparc_TARGET_ARCH -}
1949 %************************************************************************
1951 \subsection{Conditional jumps}
1953 %************************************************************************
1955 Conditional jumps are always to local labels, so we can use branch
1956 instructions. We peek at the arguments to decide what kind of
1959 ALPHA: For comparisons with 0, we're laughing, because we can just do
1960 the desired conditional branch.
1962 I386: First, we have to ensure that the condition
1963 codes are set according to the supplied comparison operation.
1965 SPARC: First, we have to ensure that the condition codes are set
1966 according to the supplied comparison operation. We generate slightly
1967 different code for floating point comparisons, because a floating
1968 point operation cannot directly precede a @BF@. We assume the worst
1969 and fill that slot with a @NOP@.
1971 SPARC: Do not fill the delay slots here; you will confuse the register
1976 :: CLabel -- the branch target
1977 -> StixTree -- the condition on which to branch
1978 -> UniqSM InstrBlock
1980 #if alpha_TARGET_ARCH
1982 genCondJump lbl (StPrim op [x, StInt 0])
1983 = getRegister x `thenUs` \ register ->
1984 getNewRegNCG (registerRep register)
1987 code = registerCode register tmp
1988 value = registerName register tmp
1989 pk = registerRep register
1990 target = ImmCLbl lbl
1992 returnSeq code [BI (cmpOp op) value target]
1994 cmpOp CharGtOp = GTT
1996 cmpOp CharEqOp = EQQ
1998 cmpOp CharLtOp = LTT
2007 cmpOp WordGeOp = ALWAYS
2008 cmpOp WordEqOp = EQQ
2010 cmpOp WordLtOp = NEVER
2011 cmpOp WordLeOp = EQQ
2013 cmpOp AddrGeOp = ALWAYS
2014 cmpOp AddrEqOp = EQQ
2016 cmpOp AddrLtOp = NEVER
2017 cmpOp AddrLeOp = EQQ
2019 genCondJump lbl (StPrim op [x, StDouble 0.0])
2020 = getRegister x `thenUs` \ register ->
2021 getNewRegNCG (registerRep register)
2024 code = registerCode register tmp
2025 value = registerName register tmp
2026 pk = registerRep register
2027 target = ImmCLbl lbl
2029 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2031 cmpOp FloatGtOp = GTT
2032 cmpOp FloatGeOp = GE
2033 cmpOp FloatEqOp = EQQ
2034 cmpOp FloatNeOp = NE
2035 cmpOp FloatLtOp = LTT
2036 cmpOp FloatLeOp = LE
2037 cmpOp DoubleGtOp = GTT
2038 cmpOp DoubleGeOp = GE
2039 cmpOp DoubleEqOp = EQQ
2040 cmpOp DoubleNeOp = NE
2041 cmpOp DoubleLtOp = LTT
2042 cmpOp DoubleLeOp = LE
2044 genCondJump lbl (StPrim op [x, y])
2046 = trivialFCode pr instr x y `thenUs` \ register ->
2047 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2049 code = registerCode register tmp
2050 result = registerName register tmp
2051 target = ImmCLbl lbl
2053 returnUs (code . mkSeqInstr (BF cond result target))
2055 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2057 fltCmpOp op = case op of
2071 (instr, cond) = case op of
2072 FloatGtOp -> (FCMP TF LE, EQQ)
2073 FloatGeOp -> (FCMP TF LTT, EQQ)
2074 FloatEqOp -> (FCMP TF EQQ, NE)
2075 FloatNeOp -> (FCMP TF EQQ, EQQ)
2076 FloatLtOp -> (FCMP TF LTT, NE)
2077 FloatLeOp -> (FCMP TF LE, NE)
2078 DoubleGtOp -> (FCMP TF LE, EQQ)
2079 DoubleGeOp -> (FCMP TF LTT, EQQ)
2080 DoubleEqOp -> (FCMP TF EQQ, NE)
2081 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2082 DoubleLtOp -> (FCMP TF LTT, NE)
2083 DoubleLeOp -> (FCMP TF LE, NE)
2085 genCondJump lbl (StPrim op [x, y])
2086 = trivialCode instr x y `thenUs` \ register ->
2087 getNewRegNCG IntRep `thenUs` \ tmp ->
2089 code = registerCode register tmp
2090 result = registerName register tmp
2091 target = ImmCLbl lbl
2093 returnUs (code . mkSeqInstr (BI cond result target))
2095 (instr, cond) = case op of
2096 CharGtOp -> (CMP LE, EQQ)
2097 CharGeOp -> (CMP LTT, EQQ)
2098 CharEqOp -> (CMP EQQ, NE)
2099 CharNeOp -> (CMP EQQ, EQQ)
2100 CharLtOp -> (CMP LTT, NE)
2101 CharLeOp -> (CMP LE, NE)
2102 IntGtOp -> (CMP LE, EQQ)
2103 IntGeOp -> (CMP LTT, EQQ)
2104 IntEqOp -> (CMP EQQ, NE)
2105 IntNeOp -> (CMP EQQ, EQQ)
2106 IntLtOp -> (CMP LTT, NE)
2107 IntLeOp -> (CMP LE, NE)
2108 WordGtOp -> (CMP ULE, EQQ)
2109 WordGeOp -> (CMP ULT, EQQ)
2110 WordEqOp -> (CMP EQQ, NE)
2111 WordNeOp -> (CMP EQQ, EQQ)
2112 WordLtOp -> (CMP ULT, NE)
2113 WordLeOp -> (CMP ULE, NE)
2114 AddrGtOp -> (CMP ULE, EQQ)
2115 AddrGeOp -> (CMP ULT, EQQ)
2116 AddrEqOp -> (CMP EQQ, NE)
2117 AddrNeOp -> (CMP EQQ, EQQ)
2118 AddrLtOp -> (CMP ULT, NE)
2119 AddrLeOp -> (CMP ULE, NE)
2121 #endif {- alpha_TARGET_ARCH -}
2122 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2123 #if i386_TARGET_ARCH
2125 genCondJump lbl bool
2126 = getCondCode bool `thenUs` \ condition ->
2128 code = condCode condition
2129 cond = condName condition
2130 target = ImmCLbl lbl
2132 returnSeq code [JXX cond lbl]
2134 #endif {- i386_TARGET_ARCH -}
2135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2136 #if sparc_TARGET_ARCH
2138 genCondJump lbl bool
2139 = getCondCode bool `thenUs` \ condition ->
2141 code = condCode condition
2142 cond = condName condition
2143 target = ImmCLbl lbl
2146 if condFloat condition then
2147 [NOP, BF cond False target, NOP]
2149 [BI cond False target, NOP]
2152 #endif {- sparc_TARGET_ARCH -}
2155 %************************************************************************
2157 \subsection{Generating C calls}
2159 %************************************************************************
2161 Now the biggest nightmare---calls. Most of the nastiness is buried in
2162 @get_arg@, which moves the arguments to the correct registers/stack
2163 locations. Apart from that, the code is easy.
2165 (If applicable) Do not fill the delay slots here; you will confuse the
2170 :: FAST_STRING -- function to call
2171 -> PrimRep -- type of the result
2172 -> [StixTree] -- arguments (of mixed type)
2173 -> UniqSM InstrBlock
2175 #if alpha_TARGET_ARCH
2177 genCCall fn kind args
2178 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2179 `thenUs` \ ((unused,_), argCode) ->
2181 nRegs = length allArgRegs - length unused
2182 code = asmParThen (map ($ asmVoid) argCode)
2185 LDA pv (AddrImm (ImmLab (ptext fn))),
2186 JSR ra (AddrReg pv) nRegs,
2187 LDGP gp (AddrReg ra)]
2189 ------------------------
2190 {- Try to get a value into a specific register (or registers) for
2191 a call. The first 6 arguments go into the appropriate
2192 argument register (separate registers for integer and floating
2193 point arguments, but used in lock-step), and the remaining
2194 arguments are dumped to the stack, beginning at 0(sp). Our
2195 first argument is a pair of the list of remaining argument
2196 registers to be assigned for this call and the next stack
2197 offset to use for overflowing arguments. This way,
2198 @get_Arg@ can be applied to all of a call's arguments using
2202 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2203 -> StixTree -- Current argument
2204 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2206 -- We have to use up all of our argument registers first...
2208 get_arg ((iDst,fDst):dsts, offset) arg
2209 = getRegister arg `thenUs` \ register ->
2211 reg = if isFloatingRep pk then fDst else iDst
2212 code = registerCode register reg
2213 src = registerName register reg
2214 pk = registerRep register
2217 if isFloatingRep pk then
2218 ((dsts, offset), if isFixed register then
2219 code . mkSeqInstr (FMOV src fDst)
2222 ((dsts, offset), if isFixed register then
2223 code . mkSeqInstr (OR src (RIReg src) iDst)
2226 -- Once we have run out of argument registers, we move to the
2229 get_arg ([], offset) arg
2230 = getRegister arg `thenUs` \ register ->
2231 getNewRegNCG (registerRep register)
2234 code = registerCode register tmp
2235 src = registerName register tmp
2236 pk = registerRep register
2237 sz = primRepToSize pk
2239 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2241 #endif {- alpha_TARGET_ARCH -}
2242 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2243 #if i386_TARGET_ARCH
2245 genCCall fn kind [StInt i]
2246 | fn == SLIT ("PerformGC_wrapper")
2247 = getUniqLabelNCG `thenUs` \ lbl ->
2249 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2250 MOV L (OpImm (ImmCLbl lbl))
2251 -- this is hardwired
2252 (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
2253 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2258 genCCall fn kind args
2259 = mapUs get_call_arg args `thenUs` \ argCode ->
2262 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
2263 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2266 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2267 call = [CALL fn__2 -- ,
2268 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
2269 -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2272 returnSeq (code1 . code2) call
2274 -- function names that begin with '.' are assumed to be special
2275 -- internally generated names like '.mul,' which don't get an
2276 -- underscore prefix
2277 -- ToDo:needed (WDP 96/03) ???
2278 fn__2 = case (_HEAD_ fn) of
2279 '.' -> ImmLit (ptext fn)
2280 _ -> ImmLab (ptext fn)
2283 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2286 = get_op arg `thenUs` \ (code, op, sz) ->
2287 returnUs (code . mkSeqInstr (PUSH sz op))
2292 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2295 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2297 get_op (StInd pk mem)
2298 = getAmode mem `thenUs` \ amode ->
2300 code = amodeCode amode --asmVoid
2301 addr = amodeAddr amode
2302 sz = primRepToSize pk
2304 returnUs (code, OpAddr addr, sz)
2307 = getRegister op `thenUs` \ register ->
2308 getNewRegNCG (registerRep register)
2311 code = registerCode register tmp
2312 reg = registerName register tmp
2313 pk = registerRep register
2314 sz = primRepToSize pk
2316 returnUs (code, OpReg reg, sz)
2318 #endif {- i386_TARGET_ARCH -}
2319 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2320 #if sparc_TARGET_ARCH
2322 genCCall fn kind args
2323 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2324 `thenUs` \ ((unused,_), argCode) ->
2326 nRegs = length allArgRegs - length unused
2327 call = CALL fn__2 nRegs False
2328 code = asmParThen (map ($ asmVoid) argCode)
2330 returnSeq code [call, NOP]
2332 -- function names that begin with '.' are assumed to be special
2333 -- internally generated names like '.mul,' which don't get an
2334 -- underscore prefix
2335 -- ToDo:needed (WDP 96/03) ???
2336 fn__2 = case (_HEAD_ fn) of
2337 '.' -> ImmLit (ptext fn)
2338 _ -> ImmLab (ptext fn)
2340 ------------------------------------
2341 {- Try to get a value into a specific register (or registers) for
2342 a call. The SPARC calling convention is an absolute
2343 nightmare. The first 6x32 bits of arguments are mapped into
2344 %o0 through %o5, and the remaining arguments are dumped to the
2345 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2346 first argument is a pair of the list of remaining argument
2347 registers to be assigned for this call and the next stack
2348 offset to use for overflowing arguments. This way,
2349 @get_arg@ can be applied to all of a call's arguments using
2353 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2354 -> StixTree -- Current argument
2355 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2357 -- We have to use up all of our argument registers first...
2359 get_arg (dst:dsts, offset) arg
2360 = getRegister arg `thenUs` \ register ->
2361 getNewRegNCG (registerRep register)
2364 reg = if isFloatingRep pk then tmp else dst
2365 code = registerCode register reg
2366 src = registerName register reg
2367 pk = registerRep register
2369 returnUs (case pk of
2372 [] -> (([], offset + 1), code . mkSeqInstrs [
2373 -- conveniently put the second part in the right stack
2374 -- location, and load the first part into %o5
2375 ST DF src (spRel (offset - 1)),
2376 LD W (spRel (offset - 1)) dst])
2377 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2378 ST DF src (spRel (-2)),
2379 LD W (spRel (-2)) dst,
2380 LD W (spRel (-1)) dst__2])
2381 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2382 ST F src (spRel (-2)),
2383 LD W (spRel (-2)) dst])
2384 _ -> ((dsts, offset), if isFixed register then
2385 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2388 -- Once we have run out of argument registers, we move to the
2391 get_arg ([], offset) arg
2392 = getRegister arg `thenUs` \ register ->
2393 getNewRegNCG (registerRep register)
2396 code = registerCode register tmp
2397 src = registerName register tmp
2398 pk = registerRep register
2399 sz = primRepToSize pk
2400 words = if pk == DoubleRep then 2 else 1
2402 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2404 #endif {- sparc_TARGET_ARCH -}
2407 %************************************************************************
2409 \subsection{Support bits}
2411 %************************************************************************
2413 %************************************************************************
2415 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2417 %************************************************************************
2419 Turn those condition codes into integers now (when they appear on
2420 the right hand side of an assignment).
2422 (If applicable) Do not fill the delay slots here; you will confuse the
2426 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2428 #if alpha_TARGET_ARCH
2429 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2430 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2431 #endif {- alpha_TARGET_ARCH -}
2433 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2434 #if i386_TARGET_ARCH
2437 = condIntCode cond x y `thenUs` \ condition ->
2438 getNewRegNCG IntRep `thenUs` \ tmp ->
2439 --getRegister dst `thenUs` \ register ->
2441 --code2 = registerCode register tmp asmVoid
2442 --dst__2 = registerName register tmp
2443 code = condCode condition
2444 cond = condName condition
2445 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2446 code__2 dst = code . mkSeqInstrs [
2447 SETCC cond (OpReg tmp),
2448 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2449 MOV L (OpReg tmp) (OpReg dst)]
2451 returnUs (Any IntRep code__2)
2454 = getUniqLabelNCG `thenUs` \ lbl1 ->
2455 getUniqLabelNCG `thenUs` \ lbl2 ->
2456 condFltCode cond x y `thenUs` \ condition ->
2458 code = condCode condition
2459 cond = condName condition
2460 code__2 dst = code . mkSeqInstrs [
2462 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2465 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2468 returnUs (Any IntRep code__2)
2470 #endif {- i386_TARGET_ARCH -}
2471 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2472 #if sparc_TARGET_ARCH
2474 condIntReg EQQ x (StInt 0)
2475 = getRegister x `thenUs` \ register ->
2476 getNewRegNCG IntRep `thenUs` \ tmp ->
2478 code = registerCode register tmp
2479 src = registerName register tmp
2480 code__2 dst = code . mkSeqInstrs [
2481 SUB False True g0 (RIReg src) g0,
2482 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2484 returnUs (Any IntRep code__2)
2487 = getRegister x `thenUs` \ register1 ->
2488 getRegister y `thenUs` \ register2 ->
2489 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2490 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2492 code1 = registerCode register1 tmp1 asmVoid
2493 src1 = registerName register1 tmp1
2494 code2 = registerCode register2 tmp2 asmVoid
2495 src2 = registerName register2 tmp2
2496 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2497 XOR False src1 (RIReg src2) dst,
2498 SUB False True g0 (RIReg dst) g0,
2499 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2501 returnUs (Any IntRep code__2)
2503 condIntReg NE x (StInt 0)
2504 = getRegister x `thenUs` \ register ->
2505 getNewRegNCG IntRep `thenUs` \ tmp ->
2507 code = registerCode register tmp
2508 src = registerName register tmp
2509 code__2 dst = code . mkSeqInstrs [
2510 SUB False True g0 (RIReg src) g0,
2511 ADD True False g0 (RIImm (ImmInt 0)) dst]
2513 returnUs (Any IntRep code__2)
2516 = getRegister x `thenUs` \ register1 ->
2517 getRegister y `thenUs` \ register2 ->
2518 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2519 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2521 code1 = registerCode register1 tmp1 asmVoid
2522 src1 = registerName register1 tmp1
2523 code2 = registerCode register2 tmp2 asmVoid
2524 src2 = registerName register2 tmp2
2525 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2526 XOR False src1 (RIReg src2) dst,
2527 SUB False True g0 (RIReg dst) g0,
2528 ADD True False g0 (RIImm (ImmInt 0)) dst]
2530 returnUs (Any IntRep code__2)
2533 = getUniqLabelNCG `thenUs` \ lbl1 ->
2534 getUniqLabelNCG `thenUs` \ lbl2 ->
2535 condIntCode cond x y `thenUs` \ condition ->
2537 code = condCode condition
2538 cond = condName condition
2539 code__2 dst = code . mkSeqInstrs [
2540 BI cond False (ImmCLbl lbl1), NOP,
2541 OR False g0 (RIImm (ImmInt 0)) dst,
2542 BI ALWAYS False (ImmCLbl lbl2), NOP,
2544 OR False g0 (RIImm (ImmInt 1)) dst,
2547 returnUs (Any IntRep code__2)
2550 = getUniqLabelNCG `thenUs` \ lbl1 ->
2551 getUniqLabelNCG `thenUs` \ lbl2 ->
2552 condFltCode cond x y `thenUs` \ condition ->
2554 code = condCode condition
2555 cond = condName condition
2556 code__2 dst = code . mkSeqInstrs [
2558 BF cond False (ImmCLbl lbl1), NOP,
2559 OR False g0 (RIImm (ImmInt 0)) dst,
2560 BI ALWAYS False (ImmCLbl lbl2), NOP,
2562 OR False g0 (RIImm (ImmInt 1)) dst,
2565 returnUs (Any IntRep code__2)
2567 #endif {- sparc_TARGET_ARCH -}
2570 %************************************************************************
2572 \subsubsection{@trivial*Code@: deal with trivial instructions}
2574 %************************************************************************
2576 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2577 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2578 for constants on the right hand side, because that's where the generic
2579 optimizer will have put them.
2581 Similarly, for unary instructions, we don't have to worry about
2582 matching an StInt as the argument, because genericOpt will already
2583 have handled the constant-folding.
2587 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2588 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2589 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2591 -> StixTree -> StixTree -- the two arguments
2596 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2597 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2599 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2600 (Size -> Operand -> Instr)
2601 -> (Size -> Operand -> Instr) {-reversed instr-}
2603 -> Instr {-reversed instr: pop-}
2605 -> StixTree -> StixTree -- the two arguments
2609 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2610 ,IF_ARCH_i386 ((Operand -> Instr)
2611 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2613 -> StixTree -- the one argument
2618 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2619 ,IF_ARCH_i386 (Instr
2620 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2622 -> StixTree -- the one argument
2625 #if alpha_TARGET_ARCH
2627 trivialCode instr x (StInt y)
2629 = getRegister x `thenUs` \ register ->
2630 getNewRegNCG IntRep `thenUs` \ tmp ->
2632 code = registerCode register tmp
2633 src1 = registerName register tmp
2634 src2 = ImmInt (fromInteger y)
2635 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2637 returnUs (Any IntRep code__2)
2639 trivialCode instr x y
2640 = getRegister x `thenUs` \ register1 ->
2641 getRegister y `thenUs` \ register2 ->
2642 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2643 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2645 code1 = registerCode register1 tmp1 asmVoid
2646 src1 = registerName register1 tmp1
2647 code2 = registerCode register2 tmp2 asmVoid
2648 src2 = registerName register2 tmp2
2649 code__2 dst = asmParThen [code1, code2] .
2650 mkSeqInstr (instr src1 (RIReg src2) dst)
2652 returnUs (Any IntRep code__2)
2655 trivialUCode instr x
2656 = getRegister x `thenUs` \ register ->
2657 getNewRegNCG IntRep `thenUs` \ tmp ->
2659 code = registerCode register tmp
2660 src = registerName register tmp
2661 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2663 returnUs (Any IntRep code__2)
2666 trivialFCode _ instr x y
2667 = getRegister x `thenUs` \ register1 ->
2668 getRegister y `thenUs` \ register2 ->
2669 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2670 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2672 code1 = registerCode register1 tmp1
2673 src1 = registerName register1 tmp1
2675 code2 = registerCode register2 tmp2
2676 src2 = registerName register2 tmp2
2678 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2679 mkSeqInstr (instr src1 src2 dst)
2681 returnUs (Any DoubleRep code__2)
2683 trivialUFCode _ instr x
2684 = getRegister x `thenUs` \ register ->
2685 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2687 code = registerCode register tmp
2688 src = registerName register tmp
2689 code__2 dst = code . mkSeqInstr (instr src dst)
2691 returnUs (Any DoubleRep code__2)
2693 #endif {- alpha_TARGET_ARCH -}
2694 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2695 #if i386_TARGET_ARCH
2697 trivialCode instr x y
2699 = getRegister x `thenUs` \ register1 ->
2700 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2702 fixedname = registerName register1 eax
2703 code__2 dst = let code1 = registerCode register1 dst
2704 src1 = registerName register1 dst
2706 if isFixed register1 && src1 /= dst
2707 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2708 instr (OpImm imm__2) (OpReg dst)]
2710 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2712 returnUs (Any IntRep code__2)
2715 imm__2 = case imm of Just x -> x
2717 trivialCode instr x y
2719 = getRegister y `thenUs` \ register1 ->
2720 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2722 fixedname = registerName register1 eax
2723 code__2 dst = let code1 = registerCode register1 dst
2724 src1 = registerName register1 dst
2726 if isFixed register1 && src1 /= dst
2727 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2728 instr (OpImm imm__2) (OpReg dst)]
2730 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2732 returnUs (Any IntRep code__2)
2735 imm__2 = case imm of Just x -> x
2737 trivialCode instr x (StInd pk mem)
2738 = getRegister x `thenUs` \ register ->
2739 --getNewRegNCG IntRep `thenUs` \ tmp ->
2740 getAmode mem `thenUs` \ amode ->
2742 fixedname = registerName register eax
2743 code2 = amodeCode amode asmVoid
2744 src2 = amodeAddr amode
2745 code__2 dst = let code1 = registerCode register dst asmVoid
2746 src1 = registerName register dst
2747 in asmParThen [code1, code2] .
2748 if isFixed register && src1 /= dst
2749 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2750 instr (OpAddr src2) (OpReg dst)]
2752 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2754 returnUs (Any pk code__2)
2756 trivialCode instr (StInd pk mem) y
2757 = getRegister y `thenUs` \ register ->
2758 --getNewRegNCG IntRep `thenUs` \ tmp ->
2759 getAmode mem `thenUs` \ amode ->
2761 fixedname = registerName register eax
2762 code2 = amodeCode amode asmVoid
2763 src2 = amodeAddr amode
2765 code1 = registerCode register dst asmVoid
2766 src1 = registerName register dst
2767 in asmParThen [code1, code2] .
2768 if isFixed register && src1 /= dst
2769 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2770 instr (OpAddr src2) (OpReg dst)]
2772 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2774 returnUs (Any pk code__2)
2776 trivialCode instr x y
2777 = getRegister x `thenUs` \ register1 ->
2778 getRegister y `thenUs` \ register2 ->
2779 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2780 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2782 fixedname = registerName register1 eax
2783 code2 = registerCode register2 tmp2 asmVoid
2784 src2 = registerName register2 tmp2
2786 code1 = registerCode register1 dst asmVoid
2787 src1 = registerName register1 dst
2788 in asmParThen [code1, code2] .
2789 if isFixed register1 && src1 /= dst
2790 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2791 instr (OpReg src2) (OpReg dst)]
2793 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2795 returnUs (Any IntRep code__2)
2798 trivialUCode instr x
2799 = getRegister x `thenUs` \ register ->
2800 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2802 -- fixedname = registerName register eax
2804 code = registerCode register dst
2805 src = registerName register dst
2806 in code . if isFixed register && dst /= src
2807 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2809 else mkSeqInstr (instr (OpReg src))
2811 returnUs (Any IntRep code__2)
2814 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2815 = getRegister y `thenUs` \ register2 ->
2816 --getNewRegNCG (registerRep register2)
2817 -- `thenUs` \ tmp2 ->
2818 getAmode mem `thenUs` \ amode ->
2820 code1 = amodeCode amode
2821 src1 = amodeAddr amode
2824 code2 = registerCode register2 dst
2825 src2 = registerName register2 dst
2826 in asmParThen [code1 asmVoid,code2 asmVoid] .
2827 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2829 returnUs (Any pk code__2)
2831 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2832 = getRegister x `thenUs` \ register1 ->
2833 --getNewRegNCG (registerRep register1)
2834 -- `thenUs` \ tmp1 ->
2835 getAmode mem `thenUs` \ amode ->
2837 code2 = amodeCode amode
2838 src2 = amodeAddr amode
2841 code1 = registerCode register1 dst
2842 src1 = registerName register1 dst
2843 in asmParThen [code2 asmVoid,code1 asmVoid] .
2844 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2846 returnUs (Any pk code__2)
2848 trivialFCode pk _ _ _ instrpr x y
2849 = getRegister x `thenUs` \ register1 ->
2850 getRegister y `thenUs` \ register2 ->
2851 --getNewRegNCG (registerRep register1)
2852 -- `thenUs` \ tmp1 ->
2853 --getNewRegNCG (registerRep register2)
2854 -- `thenUs` \ tmp2 ->
2855 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2857 pk1 = registerRep register1
2858 code1 = registerCode register1 st0 --tmp1
2859 src1 = registerName register1 st0 --tmp1
2861 pk2 = registerRep register2
2864 code2 = registerCode register2 dst
2865 src2 = registerName register2 dst
2866 in asmParThen [code1 asmVoid, code2 asmVoid] .
2869 returnUs (Any pk1 code__2)
2872 trivialUFCode pk instr (StInd pk' mem)
2873 = getAmode mem `thenUs` \ amode ->
2875 code = amodeCode amode
2876 src = amodeAddr amode
2877 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2880 returnUs (Any pk code__2)
2882 trivialUFCode pk instr x
2883 = getRegister x `thenUs` \ register ->
2884 --getNewRegNCG pk `thenUs` \ tmp ->
2887 code = registerCode register dst
2888 src = registerName register dst
2889 in code . mkSeqInstrs [instr]
2891 returnUs (Any pk code__2)
2893 #endif {- i386_TARGET_ARCH -}
2894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2895 #if sparc_TARGET_ARCH
2897 trivialCode instr x (StInt y)
2899 = getRegister x `thenUs` \ register ->
2900 getNewRegNCG IntRep `thenUs` \ tmp ->
2902 code = registerCode register tmp
2903 src1 = registerName register tmp
2904 src2 = ImmInt (fromInteger y)
2905 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2907 returnUs (Any IntRep code__2)
2909 trivialCode instr x y
2910 = getRegister x `thenUs` \ register1 ->
2911 getRegister y `thenUs` \ register2 ->
2912 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2913 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2915 code1 = registerCode register1 tmp1 asmVoid
2916 src1 = registerName register1 tmp1
2917 code2 = registerCode register2 tmp2 asmVoid
2918 src2 = registerName register2 tmp2
2919 code__2 dst = asmParThen [code1, code2] .
2920 mkSeqInstr (instr src1 (RIReg src2) dst)
2922 returnUs (Any IntRep code__2)
2925 trivialFCode pk instr x y
2926 = getRegister x `thenUs` \ register1 ->
2927 getRegister y `thenUs` \ register2 ->
2928 getNewRegNCG (registerRep register1)
2930 getNewRegNCG (registerRep register2)
2932 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2934 promote x = asmInstr (FxTOy F DF x tmp)
2936 pk1 = registerRep register1
2937 code1 = registerCode register1 tmp1
2938 src1 = registerName register1 tmp1
2940 pk2 = registerRep register2
2941 code2 = registerCode register2 tmp2
2942 src2 = registerName register2 tmp2
2946 asmParThen [code1 asmVoid, code2 asmVoid] .
2947 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2948 else if pk1 == FloatRep then
2949 asmParThen [code1 (promote src1), code2 asmVoid] .
2950 mkSeqInstr (instr DF tmp src2 dst)
2952 asmParThen [code1 asmVoid, code2 (promote src2)] .
2953 mkSeqInstr (instr DF src1 tmp dst)
2955 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2958 trivialUCode instr x
2959 = getRegister x `thenUs` \ register ->
2960 getNewRegNCG IntRep `thenUs` \ tmp ->
2962 code = registerCode register tmp
2963 src = registerName register tmp
2964 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2966 returnUs (Any IntRep code__2)
2969 trivialUFCode pk instr x
2970 = getRegister x `thenUs` \ register ->
2971 getNewRegNCG pk `thenUs` \ tmp ->
2973 code = registerCode register tmp
2974 src = registerName register tmp
2975 code__2 dst = code . mkSeqInstr (instr src dst)
2977 returnUs (Any pk code__2)
2979 #endif {- sparc_TARGET_ARCH -}
2982 %************************************************************************
2984 \subsubsection{Coercing to/from integer/floating-point...}
2986 %************************************************************************
2988 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2989 to be generated. Here we just change the type on the Register passed
2990 on up. The code is machine-independent.
2992 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2993 conversions. We have to store temporaries in memory to move
2994 between the integer and the floating point register sets.
2997 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2998 coerceFltCode :: StixTree -> UniqSM Register
3000 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3001 coerceFP2Int :: StixTree -> UniqSM Register
3004 = getRegister x `thenUs` \ register ->
3007 Fixed _ reg code -> Fixed pk reg code
3008 Any _ code -> Any pk code
3013 = getRegister x `thenUs` \ register ->
3016 Fixed _ reg code -> Fixed DoubleRep reg code
3017 Any _ code -> Any DoubleRep code
3022 #if alpha_TARGET_ARCH
3025 = getRegister x `thenUs` \ register ->
3026 getNewRegNCG IntRep `thenUs` \ reg ->
3028 code = registerCode register reg
3029 src = registerName register reg
3031 code__2 dst = code . mkSeqInstrs [
3033 LD TF dst (spRel 0),
3036 returnUs (Any DoubleRep code__2)
3040 = getRegister x `thenUs` \ register ->
3041 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3043 code = registerCode register tmp
3044 src = registerName register tmp
3046 code__2 dst = code . mkSeqInstrs [
3048 ST TF tmp (spRel 0),
3051 returnUs (Any IntRep code__2)
3053 #endif {- alpha_TARGET_ARCH -}
3054 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3055 #if i386_TARGET_ARCH
3058 = getRegister x `thenUs` \ register ->
3059 getNewRegNCG IntRep `thenUs` \ reg ->
3061 code = registerCode register reg
3062 src = registerName register reg
3064 code__2 dst = code . mkSeqInstrs [
3065 -- to fix: should spill instead of using R1
3066 MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
3067 FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3069 returnUs (Any pk code__2)
3073 = getRegister x `thenUs` \ register ->
3074 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3076 code = registerCode register tmp
3077 src = registerName register tmp
3078 pk = registerRep register
3081 in code . mkSeqInstrs [
3083 FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
3084 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3086 returnUs (Any IntRep code__2)
3088 #endif {- i386_TARGET_ARCH -}
3089 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3090 #if sparc_TARGET_ARCH
3093 = getRegister x `thenUs` \ register ->
3094 getNewRegNCG IntRep `thenUs` \ reg ->
3096 code = registerCode register reg
3097 src = registerName register reg
3099 code__2 dst = code . mkSeqInstrs [
3100 ST W src (spRel (-2)),
3101 LD W (spRel (-2)) dst,
3102 FxTOy W (primRepToSize pk) dst dst]
3104 returnUs (Any pk code__2)
3108 = getRegister x `thenUs` \ register ->
3109 getNewRegNCG IntRep `thenUs` \ reg ->
3110 getNewRegNCG FloatRep `thenUs` \ tmp ->
3112 code = registerCode register reg
3113 src = registerName register reg
3114 pk = registerRep register
3116 code__2 dst = code . mkSeqInstrs [
3117 FxTOy (primRepToSize pk) W src tmp,
3118 ST W tmp (spRel (-2)),
3119 LD W (spRel (-2)) dst]
3121 returnUs (Any IntRep code__2)
3123 #endif {- sparc_TARGET_ARCH -}
3126 %************************************************************************
3128 \subsubsection{Coercing integer to @Char@...}
3130 %************************************************************************
3132 Integer to character conversion. Where applicable, we try to do this
3133 in one step if the original object is in memory.
3136 chrCode :: StixTree -> UniqSM Register
3138 #if alpha_TARGET_ARCH
3141 = getRegister x `thenUs` \ register ->
3142 getNewRegNCG IntRep `thenUs` \ reg ->
3144 code = registerCode register reg
3145 src = registerName register reg
3146 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3148 returnUs (Any IntRep code__2)
3150 #endif {- alpha_TARGET_ARCH -}
3151 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3152 #if i386_TARGET_ARCH
3155 = getRegister x `thenUs` \ register ->
3156 --getNewRegNCG IntRep `thenUs` \ reg ->
3158 fixedname = registerName register eax
3160 code = registerCode register dst
3161 src = registerName register dst
3163 if isFixed register && src /= dst
3164 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3165 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3166 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3168 returnUs (Any IntRep code__2)
3170 #endif {- i386_TARGET_ARCH -}
3171 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3172 #if sparc_TARGET_ARCH
3174 chrCode (StInd pk mem)
3175 = getAmode mem `thenUs` \ amode ->
3177 code = amodeCode amode
3178 src = amodeAddr amode
3179 src_off = addrOffset src 3
3180 src__2 = case src_off of Just x -> x
3181 code__2 dst = if maybeToBool src_off then
3182 code . mkSeqInstr (LD BU src__2 dst)
3184 code . mkSeqInstrs [
3185 LD (primRepToSize pk) src dst,
3186 AND False dst (RIImm (ImmInt 255)) dst]
3188 returnUs (Any pk code__2)
3191 = getRegister x `thenUs` \ register ->
3192 getNewRegNCG IntRep `thenUs` \ reg ->
3194 code = registerCode register reg
3195 src = registerName register reg
3196 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3198 returnUs (Any IntRep code__2)
3200 #endif {- sparc_TARGET_ARCH -}
3203 %************************************************************************
3205 \subsubsection{Absolute value on integers}
3207 %************************************************************************
3209 Absolute value on integers, mostly for gmp size check macros. Again,
3210 the argument cannot be an StInt, because genericOpt already folded
3213 If applicable, do not fill the delay slots here; you will confuse the
3217 absIntCode :: StixTree -> UniqSM Register
3219 #if alpha_TARGET_ARCH
3220 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3221 #endif {- alpha_TARGET_ARCH -}
3223 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3224 #if i386_TARGET_ARCH
3227 = getRegister x `thenUs` \ register ->
3228 --getNewRegNCG IntRep `thenUs` \ reg ->
3229 getUniqLabelNCG `thenUs` \ lbl ->
3231 code__2 dst = let code = registerCode register dst
3232 src = registerName register dst
3233 in code . if isFixed register && dst /= src
3234 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3235 TEST L (OpReg dst) (OpReg dst),
3239 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3244 returnUs (Any IntRep code__2)
3246 #endif {- i386_TARGET_ARCH -}
3247 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3248 #if sparc_TARGET_ARCH
3251 = getRegister x `thenUs` \ register ->
3252 getNewRegNCG IntRep `thenUs` \ reg ->
3253 getUniqLabelNCG `thenUs` \ lbl ->
3255 code = registerCode register reg
3256 src = registerName register reg
3257 code__2 dst = code . mkSeqInstrs [
3258 SUB False True g0 (RIReg src) dst,
3259 BI GE False (ImmCLbl lbl), NOP,
3260 OR False g0 (RIReg src) dst,
3263 returnUs (Any IntRep code__2)
3265 #endif {- sparc_TARGET_ARCH -}