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
26 #define MachRegsImmAddr MachRegs.ImmAddr
29 #define MachRegsAddr Addr
30 #define MachRegsAddrRegImm AddrRegImm
31 #define MachRegsAddrRegReg AddrRegReg
32 #define MachRegsImmAddr ImmAddr
35 import AbsCSyn ( MagicId )
36 import AbsCUtils ( magicIdPrimRep )
37 import CLabel ( isAsmTemp, CLabel )
38 import Maybes ( maybeToBool, expectJust )
39 import OrdList -- quite a bit of it
40 import Outputable ( PprStyle(..) )
41 import Pretty ( ptext, rational )
42 import PrimRep ( isFloatingRep, PrimRep(..) )
43 import PrimOp ( PrimOp(..), showPrimOp )
44 import Stix ( getUniqLabelNCG, StixTree(..),
45 StixReg(..), CodeSegment(..)
47 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
48 mapAccumLUs, SYN_IE(UniqSM)
50 import Util ( panic, assertPanic )
53 Code extractor for an entire stix tree---stix statement level.
56 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
58 stmt2Instrs stmt = case stmt of
59 StComment s -> returnInstr (COMMENT s)
60 StSegment seg -> returnInstr (SEGMENT seg)
61 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
62 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
63 StLabel lab -> returnInstr (LABEL lab)
65 StJump arg -> genJump arg
66 StCondJump lab arg -> genCondJump lab arg
67 StCall fn VoidRep args -> genCCall fn VoidRep args
70 | isFloatingRep pk -> assignFltCode pk dst src
71 | otherwise -> assignIntCode pk dst src
74 -- When falling through on the Alpha, we still have to load pv
75 -- with the address of the next routine, so that it can load gp.
76 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
80 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
81 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
82 (foldr1 (.) codes xs))
84 getData :: StixTree -> UniqSM (InstrBlock, Imm)
86 getData (StInt i) = returnUs (id, ImmInteger i)
87 getData (StDouble d) = returnUs (id, dblImmLit d)
88 getData (StLitLbl s) = returnUs (id, ImmLab s)
89 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
90 getData (StCLbl l) = returnUs (id, ImmCLbl l)
91 getData (StString s) =
92 getUniqLabelNCG `thenUs` \ lbl ->
93 returnUs (mkSeqInstrs [LABEL lbl,
94 ASCII True (_UNPK_ s)],
98 %************************************************************************
100 \subsection{General things for putting together code sequences}
102 %************************************************************************
105 type InstrList = OrdList Instr
106 type InstrBlock = InstrList -> InstrList
109 asmVoid = mkEmptyList
111 asmInstr :: Instr -> InstrList
112 asmInstr i = mkUnitList i
114 asmSeq :: [Instr] -> InstrList
115 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
117 asmParThen :: [InstrList] -> InstrBlock
118 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
120 returnInstr :: Instr -> UniqSM InstrBlock
121 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
123 returnInstrs :: [Instr] -> UniqSM InstrBlock
124 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
126 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
127 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
129 mkSeqInstr :: Instr -> InstrBlock
130 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
132 mkSeqInstrs :: [Instr] -> InstrBlock
133 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
137 mangleIndexTree :: StixTree -> StixTree
139 mangleIndexTree (StIndex pk base (StInt i))
140 = StPrim IntAddOp [base, off]
142 off = StInt (i * sizeOf pk)
144 mangleIndexTree (StIndex pk base off)
145 = StPrim IntAddOp [base,
151 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
152 StPrim SllOp [off, StInt s]
155 shift DoubleRep = 3::Integer
156 shift _ = IF_ARCH_alpha(3,2)
160 maybeImm :: StixTree -> Maybe Imm
162 maybeImm (StLitLbl s) = Just (ImmLab s)
163 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
164 maybeImm (StCLbl l) = Just (ImmCLbl l)
167 | i >= toInteger minInt && i <= toInteger maxInt
168 = Just (ImmInt (fromInteger i))
170 = Just (ImmInteger i)
175 %************************************************************************
177 \subsection{The @Register@ type}
179 %************************************************************************
181 @Register@s passed up the tree. If the stix code forces the register
182 to live in a pre-decided machine register, it comes out as @Fixed@;
183 otherwise, it comes out as @Any@, and the parent can decide which
184 register to put it in.
188 = Fixed PrimRep Reg InstrBlock
189 | Any PrimRep (Reg -> InstrBlock)
191 registerCode :: Register -> Reg -> InstrBlock
192 registerCode (Fixed _ _ code) reg = code
193 registerCode (Any _ code) reg = code reg
195 registerName :: Register -> Reg -> Reg
196 registerName (Fixed _ reg _) _ = reg
197 registerName (Any _ _) reg = reg
199 registerRep :: Register -> PrimRep
200 registerRep (Fixed pk _ _) = pk
201 registerRep (Any pk _) = pk
203 isFixed :: Register -> Bool
204 isFixed (Fixed _ _ _) = True
205 isFixed (Any _ _) = False
208 Generate code to get a subtree into a @Register@:
210 getRegister :: StixTree -> UniqSM Register
212 getRegister (StReg (StixMagicId stgreg))
213 = case (magicIdRegMaybe stgreg) of
214 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
217 getRegister (StReg (StixTemp u pk))
218 = returnUs (Fixed pk (UnmappedReg u pk) id)
220 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
222 getRegister (StCall fn kind args)
223 = genCCall fn kind args `thenUs` \ call ->
224 returnUs (Fixed kind reg call)
226 reg = if isFloatingRep kind
227 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
228 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
230 getRegister (StString s)
231 = getUniqLabelNCG `thenUs` \ lbl ->
233 imm_lbl = ImmCLbl lbl
235 code dst = mkSeqInstrs [
238 ASCII True (_UNPK_ s),
240 #if alpha_TARGET_ARCH
241 LDA dst (AddrImm imm_lbl)
244 MOV L (OpImm imm_lbl) (OpReg dst)
246 #if sparc_TARGET_ARCH
247 SETHI (HI imm_lbl) dst,
248 OR False dst (RIImm (LO imm_lbl)) dst
252 returnUs (Any PtrRep code)
254 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
255 = getUniqLabelNCG `thenUs` \ lbl ->
257 imm_lbl = ImmCLbl lbl
259 code dst = mkSeqInstrs [
262 ASCII False (init xs),
264 #if alpha_TARGET_ARCH
265 LDA dst (AddrImm imm_lbl)
268 MOV L (OpImm imm_lbl) (OpReg dst)
270 #if sparc_TARGET_ARCH
271 SETHI (HI imm_lbl) dst,
272 OR False dst (RIImm (LO imm_lbl)) dst
276 returnUs (Any PtrRep code)
278 xs = _UNPK_ (_TAIL_ s)
280 -- end of machine-"independent" bit; here we go on the rest...
282 #if alpha_TARGET_ARCH
284 getRegister (StDouble d)
285 = getUniqLabelNCG `thenUs` \ lbl ->
286 getNewRegNCG PtrRep `thenUs` \ tmp ->
287 let code dst = mkSeqInstrs [
290 DATA TF [ImmLab (rational d)],
292 LDA tmp (AddrImm (ImmCLbl lbl)),
293 LD TF dst (AddrReg tmp)]
295 returnUs (Any DoubleRep code)
297 getRegister (StPrim primop [x]) -- unary PrimOps
299 IntNegOp -> trivialUCode (NEG Q False) x
300 IntAbsOp -> trivialUCode (ABS Q) x
302 NotOp -> trivialUCode NOT x
304 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
305 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
307 OrdOp -> coerceIntCode IntRep x
310 Float2IntOp -> coerceFP2Int x
311 Int2FloatOp -> coerceInt2FP pr x
312 Double2IntOp -> coerceFP2Int x
313 Int2DoubleOp -> coerceInt2FP pr x
315 Double2FloatOp -> coerceFltCode x
316 Float2DoubleOp -> coerceFltCode x
318 other_op -> getRegister (StCall fn DoubleRep [x])
320 fn = case other_op of
321 FloatExpOp -> SLIT("exp")
322 FloatLogOp -> SLIT("log")
323 FloatSqrtOp -> SLIT("sqrt")
324 FloatSinOp -> SLIT("sin")
325 FloatCosOp -> SLIT("cos")
326 FloatTanOp -> SLIT("tan")
327 FloatAsinOp -> SLIT("asin")
328 FloatAcosOp -> SLIT("acos")
329 FloatAtanOp -> SLIT("atan")
330 FloatSinhOp -> SLIT("sinh")
331 FloatCoshOp -> SLIT("cosh")
332 FloatTanhOp -> SLIT("tanh")
333 DoubleExpOp -> SLIT("exp")
334 DoubleLogOp -> SLIT("log")
335 DoubleSqrtOp -> SLIT("sqrt")
336 DoubleSinOp -> SLIT("sin")
337 DoubleCosOp -> SLIT("cos")
338 DoubleTanOp -> SLIT("tan")
339 DoubleAsinOp -> SLIT("asin")
340 DoubleAcosOp -> SLIT("acos")
341 DoubleAtanOp -> SLIT("atan")
342 DoubleSinhOp -> SLIT("sinh")
343 DoubleCoshOp -> SLIT("cosh")
344 DoubleTanhOp -> SLIT("tanh")
346 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
348 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
350 CharGtOp -> trivialCode (CMP LTT) y x
351 CharGeOp -> trivialCode (CMP LE) y x
352 CharEqOp -> trivialCode (CMP EQQ) x y
353 CharNeOp -> int_NE_code x y
354 CharLtOp -> trivialCode (CMP LTT) x y
355 CharLeOp -> trivialCode (CMP LE) x y
357 IntGtOp -> trivialCode (CMP LTT) y x
358 IntGeOp -> trivialCode (CMP LE) y x
359 IntEqOp -> trivialCode (CMP EQQ) x y
360 IntNeOp -> int_NE_code x y
361 IntLtOp -> trivialCode (CMP LTT) x y
362 IntLeOp -> trivialCode (CMP LE) x y
364 WordGtOp -> trivialCode (CMP ULT) y x
365 WordGeOp -> trivialCode (CMP ULE) x y
366 WordEqOp -> trivialCode (CMP EQQ) x y
367 WordNeOp -> int_NE_code x y
368 WordLtOp -> trivialCode (CMP ULT) x y
369 WordLeOp -> trivialCode (CMP ULE) x y
371 AddrGtOp -> trivialCode (CMP ULT) y x
372 AddrGeOp -> trivialCode (CMP ULE) y x
373 AddrEqOp -> trivialCode (CMP EQQ) x y
374 AddrNeOp -> int_NE_code x y
375 AddrLtOp -> trivialCode (CMP ULT) x y
376 AddrLeOp -> trivialCode (CMP ULE) x y
378 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
379 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
380 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
381 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
382 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
383 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
385 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
386 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
387 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
388 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
389 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
390 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
392 IntAddOp -> trivialCode (ADD Q False) x y
393 IntSubOp -> trivialCode (SUB Q False) x y
394 IntMulOp -> trivialCode (MUL Q False) x y
395 IntQuotOp -> trivialCode (DIV Q False) x y
396 IntRemOp -> trivialCode (REM Q False) x y
398 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
399 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
400 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
401 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
403 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
404 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
405 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
406 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
408 AndOp -> trivialCode AND x y
409 OrOp -> trivialCode OR x y
410 SllOp -> trivialCode SLL x y
411 SraOp -> trivialCode SRA x y
412 SrlOp -> trivialCode SRL x y
414 ISllOp -> panic "AlphaGen:isll"
415 ISraOp -> panic "AlphaGen:isra"
416 ISrlOp -> panic "AlphaGen:isrl"
418 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
419 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
421 {- ------------------------------------------------------------
422 Some bizarre special code for getting condition codes into
423 registers. Integer non-equality is a test for equality
424 followed by an XOR with 1. (Integer comparisons always set
425 the result register to 0 or 1.) Floating point comparisons of
426 any kind leave the result in a floating point register, so we
427 need to wrangle an integer register out of things.
429 int_NE_code :: StixTree -> StixTree -> UniqSM Register
432 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
433 getNewRegNCG IntRep `thenUs` \ tmp ->
435 code = registerCode register tmp
436 src = registerName register tmp
437 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
439 returnUs (Any IntRep code__2)
441 {- ------------------------------------------------------------
442 Comments for int_NE_code also apply to cmpF_code
445 :: (Reg -> Reg -> Reg -> Instr)
447 -> StixTree -> StixTree
450 cmpF_code instr cond x y
451 = trivialFCode pr instr x y `thenUs` \ register ->
452 getNewRegNCG DoubleRep `thenUs` \ tmp ->
453 getUniqLabelNCG `thenUs` \ lbl ->
455 code = registerCode register tmp
456 result = registerName register tmp
458 code__2 dst = code . mkSeqInstrs [
459 OR zeroh (RIImm (ImmInt 1)) dst,
460 BF cond result (ImmCLbl lbl),
461 OR zeroh (RIReg zeroh) dst,
464 returnUs (Any IntRep code__2)
466 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
467 ------------------------------------------------------------
469 getRegister (StInd pk mem)
470 = getAmode mem `thenUs` \ amode ->
472 code = amodeCode amode
473 src = amodeAddr amode
474 size = primRepToSize pk
475 code__2 dst = code . mkSeqInstr (LD size dst src)
477 returnUs (Any pk code__2)
479 getRegister (StInt i)
482 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
484 returnUs (Any IntRep code)
487 code dst = mkSeqInstr (LDI Q dst src)
489 returnUs (Any IntRep code)
491 src = ImmInt (fromInteger i)
496 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
498 returnUs (Any PtrRep code)
501 imm__2 = case imm of Just x -> x
503 #endif {- alpha_TARGET_ARCH -}
504 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
507 getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
509 getRegister (StDouble 0.0)
511 code dst = mkSeqInstrs [FLDZ]
513 returnUs (Any DoubleRep code)
515 getRegister (StDouble 1.0)
517 code dst = mkSeqInstrs [FLD1]
519 returnUs (Any DoubleRep code)
521 getRegister (StDouble d)
522 = getUniqLabelNCG `thenUs` \ lbl ->
523 --getNewRegNCG PtrRep `thenUs` \ tmp ->
524 let code dst = mkSeqInstrs [
527 DATA DF [dblImmLit d],
529 FLD DF (OpImm (ImmCLbl lbl))
532 returnUs (Any DoubleRep code)
534 getRegister (StPrim primop [x]) -- unary PrimOps
536 IntNegOp -> trivialUCode (NEGI L) x
537 IntAbsOp -> absIntCode x
539 NotOp -> trivialUCode (NOT L) x
541 FloatNegOp -> trivialUFCode FloatRep FCHS x
542 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
543 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
545 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
547 OrdOp -> coerceIntCode IntRep x
550 Float2IntOp -> coerceFP2Int x
551 Int2FloatOp -> coerceInt2FP FloatRep x
552 Double2IntOp -> coerceFP2Int x
553 Int2DoubleOp -> coerceInt2FP DoubleRep x
555 Double2FloatOp -> coerceFltCode x
556 Float2DoubleOp -> coerceFltCode x
560 fixed_x = if is_float_op -- promote to double
561 then StPrim Float2DoubleOp [x]
564 getRegister (StCall fn DoubleRep [x])
568 FloatExpOp -> (True, SLIT("exp"))
569 FloatLogOp -> (True, SLIT("log"))
571 FloatSinOp -> (True, SLIT("sin"))
572 FloatCosOp -> (True, SLIT("cos"))
573 FloatTanOp -> (True, SLIT("tan"))
575 FloatAsinOp -> (True, SLIT("asin"))
576 FloatAcosOp -> (True, SLIT("acos"))
577 FloatAtanOp -> (True, SLIT("atan"))
579 FloatSinhOp -> (True, SLIT("sinh"))
580 FloatCoshOp -> (True, SLIT("cosh"))
581 FloatTanhOp -> (True, SLIT("tanh"))
583 DoubleExpOp -> (False, SLIT("exp"))
584 DoubleLogOp -> (False, SLIT("log"))
586 DoubleSinOp -> (False, SLIT("sin"))
587 DoubleCosOp -> (False, SLIT("cos"))
588 DoubleTanOp -> (False, SLIT("tan"))
590 DoubleAsinOp -> (False, SLIT("asin"))
591 DoubleAcosOp -> (False, SLIT("acos"))
592 DoubleAtanOp -> (False, SLIT("atan"))
594 DoubleSinhOp -> (False, SLIT("sinh"))
595 DoubleCoshOp -> (False, SLIT("cosh"))
596 DoubleTanhOp -> (False, SLIT("tanh"))
598 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
600 CharGtOp -> condIntReg GTT x y
601 CharGeOp -> condIntReg GE x y
602 CharEqOp -> condIntReg EQQ x y
603 CharNeOp -> condIntReg NE x y
604 CharLtOp -> condIntReg LTT x y
605 CharLeOp -> condIntReg LE x y
607 IntGtOp -> condIntReg GTT x y
608 IntGeOp -> condIntReg GE x y
609 IntEqOp -> condIntReg EQQ x y
610 IntNeOp -> condIntReg NE x y
611 IntLtOp -> condIntReg LTT x y
612 IntLeOp -> condIntReg LE x y
614 WordGtOp -> condIntReg GU x y
615 WordGeOp -> condIntReg GEU x y
616 WordEqOp -> condIntReg EQQ x y
617 WordNeOp -> condIntReg NE x y
618 WordLtOp -> condIntReg LU x y
619 WordLeOp -> condIntReg LEU x y
621 AddrGtOp -> condIntReg GU x y
622 AddrGeOp -> condIntReg GEU x y
623 AddrEqOp -> condIntReg EQQ x y
624 AddrNeOp -> condIntReg NE x y
625 AddrLtOp -> condIntReg LU x y
626 AddrLeOp -> condIntReg LEU x y
628 FloatGtOp -> condFltReg GTT x y
629 FloatGeOp -> condFltReg GE x y
630 FloatEqOp -> condFltReg EQQ x y
631 FloatNeOp -> condFltReg NE x y
632 FloatLtOp -> condFltReg LTT x y
633 FloatLeOp -> condFltReg LE x y
635 DoubleGtOp -> condFltReg GTT x y
636 DoubleGeOp -> condFltReg GE x y
637 DoubleEqOp -> condFltReg EQQ x y
638 DoubleNeOp -> condFltReg NE x y
639 DoubleLtOp -> condFltReg LTT x y
640 DoubleLeOp -> condFltReg LE x y
642 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
643 -- this should be optimised by the generic Opts,
644 -- I don't know why it is not (sometimes)!
646 [x, StInt 0] -> getRegister x
651 IntSubOp -> sub_code L x y
652 IntQuotOp -> quot_code L x y True{-division-}
653 IntRemOp -> quot_code L x y False{-remainder-}
654 IntMulOp -> trivialCode (IMUL L) x y {-True-}
656 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
657 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
658 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
659 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
661 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
662 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
663 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
664 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
666 AndOp -> trivialCode (AND L) x y {-True-}
667 OrOp -> trivialCode (OR L) x y {-True-}
668 SllOp -> trivialCode (SHL L) x y {-False-}
669 SraOp -> trivialCode (SAR L) x y {-False-}
670 SrlOp -> trivialCode (SHR L) x y {-False-}
672 ISllOp -> panic "I386Gen:isll"
673 ISraOp -> panic "I386Gen:isra"
674 ISrlOp -> panic "I386Gen:isrl"
676 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
677 where promote x = StPrim Float2DoubleOp [x]
678 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
680 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
682 add_code sz x (StInt y)
683 = getRegister x `thenUs` \ register ->
684 getNewRegNCG IntRep `thenUs` \ tmp ->
686 code = registerCode register tmp
687 src1 = registerName register tmp
688 src2 = ImmInt (fromInteger y)
690 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
692 returnUs (Any IntRep code__2)
694 add_code sz x (StInd _ mem)
695 = getRegister x `thenUs` \ register1 ->
696 --getNewRegNCG (registerRep register1)
697 -- `thenUs` \ tmp1 ->
698 getAmode mem `thenUs` \ amode ->
700 code2 = amodeCode amode
701 src2 = amodeAddr amode
703 fixedname = registerName register1 eax
704 code__2 dst = let code1 = registerCode register1 dst
705 src1 = registerName register1 dst
706 in asmParThen [code2 asmVoid,code1 asmVoid] .
707 if isFixed register1 && src1 /= dst
708 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
709 ADD sz (OpAddr src2) (OpReg dst)]
711 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
713 returnUs (Any IntRep code__2)
715 add_code sz (StInd _ mem) y
716 = getRegister y `thenUs` \ register2 ->
717 --getNewRegNCG (registerRep register2)
718 -- `thenUs` \ tmp2 ->
719 getAmode mem `thenUs` \ amode ->
721 code1 = amodeCode amode
722 src1 = amodeAddr amode
724 fixedname = registerName register2 eax
725 code__2 dst = let code2 = registerCode register2 dst
726 src2 = registerName register2 dst
727 in asmParThen [code1 asmVoid,code2 asmVoid] .
728 if isFixed register2 && src2 /= dst
729 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
730 ADD sz (OpAddr src1) (OpReg dst)]
732 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
734 returnUs (Any IntRep code__2)
737 = getRegister x `thenUs` \ register1 ->
738 getRegister y `thenUs` \ register2 ->
739 getNewRegNCG IntRep `thenUs` \ tmp1 ->
740 getNewRegNCG IntRep `thenUs` \ tmp2 ->
742 code1 = registerCode register1 tmp1 asmVoid
743 src1 = registerName register1 tmp1
744 code2 = registerCode register2 tmp2 asmVoid
745 src2 = registerName register2 tmp2
746 code__2 dst = asmParThen [code1, code2] .
747 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
749 returnUs (Any IntRep code__2)
752 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
754 sub_code sz x (StInt y)
755 = getRegister x `thenUs` \ register ->
756 getNewRegNCG IntRep `thenUs` \ tmp ->
758 code = registerCode register tmp
759 src1 = registerName register tmp
760 src2 = ImmInt (-(fromInteger y))
762 mkSeqInstr (LEA sz (OpAddr (MachRegsAddr (Just src1) Nothing src2)) (OpReg dst))
764 returnUs (Any IntRep code__2)
766 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
771 -> StixTree -> StixTree
772 -> Bool -- True => division, False => remainder operation
775 -- x must go into eax, edx must be a sign-extension of eax, and y
776 -- should go in some other register (or memory), so that we get
777 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
778 -- put y in memory (if it is not there already)
780 quot_code sz x (StInd pk mem) is_division
781 = getRegister x `thenUs` \ register1 ->
782 getNewRegNCG IntRep `thenUs` \ tmp1 ->
783 getAmode mem `thenUs` \ amode ->
785 code1 = registerCode register1 tmp1 asmVoid
786 src1 = registerName register1 tmp1
787 code2 = amodeCode amode asmVoid
788 src2 = amodeAddr amode
789 code__2 = asmParThen [code1, code2] .
790 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
792 IDIV sz (OpAddr src2)]
794 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
796 quot_code sz x (StInt i) is_division
797 = getRegister x `thenUs` \ register1 ->
798 getNewRegNCG IntRep `thenUs` \ tmp1 ->
800 code1 = registerCode register1 tmp1 asmVoid
801 src1 = registerName register1 tmp1
802 src2 = ImmInt (fromInteger i)
803 code__2 = asmParThen [code1] .
804 mkSeqInstrs [-- we put src2 in (ebx)
805 MOV L (OpImm src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
806 MOV L (OpReg src1) (OpReg eax),
808 IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
810 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
812 quot_code sz x y is_division
813 = getRegister x `thenUs` \ register1 ->
814 getNewRegNCG IntRep `thenUs` \ tmp1 ->
815 getRegister y `thenUs` \ register2 ->
816 getNewRegNCG IntRep `thenUs` \ tmp2 ->
818 code1 = registerCode register1 tmp1 asmVoid
819 src1 = registerName register1 tmp1
820 code2 = registerCode register2 tmp2 asmVoid
821 src2 = registerName register2 tmp2
822 code__2 = asmParThen [code1, code2] .
823 if src2 == ecx || src2 == esi
824 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
826 IDIV sz (OpReg src2)]
827 else mkSeqInstrs [ -- we put src2 in (ebx)
828 MOV L (OpReg src2) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
829 MOV L (OpReg src1) (OpReg eax),
831 IDIV sz (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
833 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
834 -----------------------
836 getRegister (StInd pk mem)
837 = getAmode mem `thenUs` \ amode ->
839 code = amodeCode amode
840 src = amodeAddr amode
841 size = primRepToSize pk
843 if pk == DoubleRep || pk == FloatRep
844 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
845 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
847 returnUs (Any pk code__2)
850 getRegister (StInt i)
852 src = ImmInt (fromInteger i)
853 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
855 returnUs (Any IntRep code)
860 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
862 returnUs (Any PtrRep code)
865 imm__2 = case imm of Just x -> x
867 #endif {- i386_TARGET_ARCH -}
868 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
869 #if sparc_TARGET_ARCH
871 getRegister (StDouble d)
872 = getUniqLabelNCG `thenUs` \ lbl ->
873 getNewRegNCG PtrRep `thenUs` \ tmp ->
874 let code dst = mkSeqInstrs [
877 DATA DF [dblImmLit d],
879 SETHI (HI (ImmCLbl lbl)) tmp,
880 LD DF (MachRegsAddrRegImm tmp (LO (ImmCLbl lbl))) dst]
882 returnUs (Any DoubleRep code)
884 getRegister (StPrim primop [x]) -- unary PrimOps
886 IntNegOp -> trivialUCode (SUB False False g0) x
887 IntAbsOp -> absIntCode x
888 NotOp -> trivialUCode (XNOR False g0) x
890 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
892 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
894 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
895 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
897 OrdOp -> coerceIntCode IntRep x
900 Float2IntOp -> coerceFP2Int x
901 Int2FloatOp -> coerceInt2FP FloatRep x
902 Double2IntOp -> coerceFP2Int x
903 Int2DoubleOp -> coerceInt2FP DoubleRep x
907 fixed_x = if is_float_op -- promote to double
908 then StPrim Float2DoubleOp [x]
911 getRegister (StCall fn DoubleRep [x])
915 FloatExpOp -> (True, SLIT("exp"))
916 FloatLogOp -> (True, SLIT("log"))
917 FloatSqrtOp -> (True, SLIT("sqrt"))
919 FloatSinOp -> (True, SLIT("sin"))
920 FloatCosOp -> (True, SLIT("cos"))
921 FloatTanOp -> (True, SLIT("tan"))
923 FloatAsinOp -> (True, SLIT("asin"))
924 FloatAcosOp -> (True, SLIT("acos"))
925 FloatAtanOp -> (True, SLIT("atan"))
927 FloatSinhOp -> (True, SLIT("sinh"))
928 FloatCoshOp -> (True, SLIT("cosh"))
929 FloatTanhOp -> (True, SLIT("tanh"))
931 DoubleExpOp -> (False, SLIT("exp"))
932 DoubleLogOp -> (False, SLIT("log"))
933 DoubleSqrtOp -> (True, SLIT("sqrt"))
935 DoubleSinOp -> (False, SLIT("sin"))
936 DoubleCosOp -> (False, SLIT("cos"))
937 DoubleTanOp -> (False, SLIT("tan"))
939 DoubleAsinOp -> (False, SLIT("asin"))
940 DoubleAcosOp -> (False, SLIT("acos"))
941 DoubleAtanOp -> (False, SLIT("atan"))
943 DoubleSinhOp -> (False, SLIT("sinh"))
944 DoubleCoshOp -> (False, SLIT("cosh"))
945 DoubleTanhOp -> (False, SLIT("tanh"))
946 _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
948 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
950 CharGtOp -> condIntReg GTT x y
951 CharGeOp -> condIntReg GE x y
952 CharEqOp -> condIntReg EQQ x y
953 CharNeOp -> condIntReg NE x y
954 CharLtOp -> condIntReg LTT x y
955 CharLeOp -> condIntReg LE x y
957 IntGtOp -> condIntReg GTT x y
958 IntGeOp -> condIntReg GE x y
959 IntEqOp -> condIntReg EQQ x y
960 IntNeOp -> condIntReg NE x y
961 IntLtOp -> condIntReg LTT x y
962 IntLeOp -> condIntReg LE x y
964 WordGtOp -> condIntReg GU x y
965 WordGeOp -> condIntReg GEU x y
966 WordEqOp -> condIntReg EQQ x y
967 WordNeOp -> condIntReg NE x y
968 WordLtOp -> condIntReg LU x y
969 WordLeOp -> condIntReg LEU x y
971 AddrGtOp -> condIntReg GU x y
972 AddrGeOp -> condIntReg GEU x y
973 AddrEqOp -> condIntReg EQQ x y
974 AddrNeOp -> condIntReg NE x y
975 AddrLtOp -> condIntReg LU x y
976 AddrLeOp -> condIntReg LEU x y
978 FloatGtOp -> condFltReg GTT x y
979 FloatGeOp -> condFltReg GE x y
980 FloatEqOp -> condFltReg EQQ x y
981 FloatNeOp -> condFltReg NE x y
982 FloatLtOp -> condFltReg LTT x y
983 FloatLeOp -> condFltReg LE x y
985 DoubleGtOp -> condFltReg GTT x y
986 DoubleGeOp -> condFltReg GE x y
987 DoubleEqOp -> condFltReg EQQ x y
988 DoubleNeOp -> condFltReg NE x y
989 DoubleLtOp -> condFltReg LTT x y
990 DoubleLeOp -> condFltReg LE x y
992 IntAddOp -> trivialCode (ADD False False) x y
993 IntSubOp -> trivialCode (SUB False False) x y
995 -- ToDo: teach about V8+ SPARC mul/div instructions
996 IntMulOp -> imul_div SLIT(".umul") x y
997 IntQuotOp -> imul_div SLIT(".div") x y
998 IntRemOp -> imul_div SLIT(".rem") x y
1000 FloatAddOp -> trivialFCode FloatRep FADD x y
1001 FloatSubOp -> trivialFCode FloatRep FSUB x y
1002 FloatMulOp -> trivialFCode FloatRep FMUL x y
1003 FloatDivOp -> trivialFCode FloatRep FDIV x y
1005 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1006 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1007 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1008 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1010 AndOp -> trivialCode (AND False) x y
1011 OrOp -> trivialCode (OR False) x y
1012 SllOp -> trivialCode SLL x y
1013 SraOp -> trivialCode SRA x y
1014 SrlOp -> trivialCode SRL x y
1016 ISllOp -> panic "SparcGen:isll"
1017 ISraOp -> panic "SparcGen:isra"
1018 ISrlOp -> panic "SparcGen:isrl"
1020 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1021 where promote x = StPrim Float2DoubleOp [x]
1022 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1024 imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1026 getRegister (StInd pk mem)
1027 = getAmode mem `thenUs` \ amode ->
1029 code = amodeCode amode
1030 src = amodeAddr amode
1031 size = primRepToSize pk
1032 code__2 dst = code . mkSeqInstr (LD size src dst)
1034 returnUs (Any pk code__2)
1036 getRegister (StInt i)
1039 src = ImmInt (fromInteger i)
1040 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1042 returnUs (Any IntRep code)
1047 code dst = mkSeqInstrs [
1048 SETHI (HI imm__2) dst,
1049 OR False dst (RIImm (LO imm__2)) dst]
1051 returnUs (Any PtrRep code)
1054 imm__2 = case imm of Just x -> x
1056 #endif {- sparc_TARGET_ARCH -}
1059 %************************************************************************
1061 \subsection{The @Amode@ type}
1063 %************************************************************************
1065 @Amode@s: Memory addressing modes passed up the tree.
1067 data Amode = Amode MachRegsAddr InstrBlock
1069 amodeAddr (Amode addr _) = addr
1070 amodeCode (Amode _ code) = code
1073 Now, given a tree (the argument to an StInd) that references memory,
1074 produce a suitable addressing mode.
1077 getAmode :: StixTree -> UniqSM Amode
1079 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1081 #if alpha_TARGET_ARCH
1083 getAmode (StPrim IntSubOp [x, StInt i])
1084 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1085 getRegister x `thenUs` \ register ->
1087 code = registerCode register tmp
1088 reg = registerName register tmp
1089 off = ImmInt (-(fromInteger i))
1091 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1093 getAmode (StPrim IntAddOp [x, StInt i])
1094 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1095 getRegister x `thenUs` \ register ->
1097 code = registerCode register tmp
1098 reg = registerName register tmp
1099 off = ImmInt (fromInteger i)
1101 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1105 = returnUs (Amode (AddrImm imm__2) id)
1108 imm__2 = case imm of Just x -> x
1111 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1112 getRegister other `thenUs` \ register ->
1114 code = registerCode register tmp
1115 reg = registerName register tmp
1117 returnUs (Amode (AddrReg reg) code)
1119 #endif {- alpha_TARGET_ARCH -}
1120 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1121 #if i386_TARGET_ARCH
1123 getAmode (StPrim IntSubOp [x, StInt i])
1124 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1125 getRegister x `thenUs` \ register ->
1127 code = registerCode register tmp
1128 reg = registerName register tmp
1129 off = ImmInt (-(fromInteger i))
1131 returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
1133 getAmode (StPrim IntAddOp [x, StInt i])
1136 code = mkSeqInstrs []
1138 returnUs (Amode (MachRegsImmAddr imm__2 (fromInteger i)) code)
1141 imm__2 = case imm of Just x -> x
1143 getAmode (StPrim IntAddOp [x, StInt i])
1144 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1145 getRegister x `thenUs` \ register ->
1147 code = registerCode register tmp
1148 reg = registerName register tmp
1149 off = ImmInt (fromInteger i)
1151 returnUs (Amode (MachRegsAddr (Just reg) Nothing off) code)
1153 getAmode (StPrim IntAddOp [x, y])
1154 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1155 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1156 getRegister x `thenUs` \ register1 ->
1157 getRegister y `thenUs` \ register2 ->
1159 code1 = registerCode register1 tmp1 asmVoid
1160 reg1 = registerName register1 tmp1
1161 code2 = registerCode register2 tmp2 asmVoid
1162 reg2 = registerName register2 tmp2
1163 code__2 = asmParThen [code1, code2]
1165 returnUs (Amode (MachRegsAddr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1170 code = mkSeqInstrs []
1172 returnUs (Amode (MachRegsImmAddr imm__2 0) code)
1175 imm__2 = case imm of Just x -> x
1178 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1179 getRegister other `thenUs` \ register ->
1181 code = registerCode register tmp
1182 reg = registerName register tmp
1185 returnUs (Amode (MachRegsAddr (Just reg) Nothing (ImmInt 0)) code)
1187 #endif {- i386_TARGET_ARCH -}
1188 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1189 #if sparc_TARGET_ARCH
1191 getAmode (StPrim IntSubOp [x, StInt i])
1193 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1194 getRegister x `thenUs` \ register ->
1196 code = registerCode register tmp
1197 reg = registerName register tmp
1198 off = ImmInt (-(fromInteger i))
1200 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1203 getAmode (StPrim IntAddOp [x, StInt i])
1205 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1206 getRegister x `thenUs` \ register ->
1208 code = registerCode register tmp
1209 reg = registerName register tmp
1210 off = ImmInt (fromInteger i)
1212 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1214 getAmode (StPrim IntAddOp [x, y])
1215 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1216 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1217 getRegister x `thenUs` \ register1 ->
1218 getRegister y `thenUs` \ register2 ->
1220 code1 = registerCode register1 tmp1 asmVoid
1221 reg1 = registerName register1 tmp1
1222 code2 = registerCode register2 tmp2 asmVoid
1223 reg2 = registerName register2 tmp2
1224 code__2 = asmParThen [code1, code2]
1226 returnUs (Amode (MachRegsAddrRegReg reg1 reg2) code__2)
1230 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1232 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1234 returnUs (Amode (MachRegsAddrRegImm tmp (LO imm__2)) code)
1237 imm__2 = case imm of Just x -> x
1240 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1241 getRegister other `thenUs` \ register ->
1243 code = registerCode register tmp
1244 reg = registerName register tmp
1247 returnUs (Amode (MachRegsAddrRegImm reg off) code)
1249 #endif {- sparc_TARGET_ARCH -}
1252 %************************************************************************
1254 \subsection{The @CondCode@ type}
1256 %************************************************************************
1258 Condition codes passed up the tree.
1260 data CondCode = CondCode Bool Cond InstrBlock
1262 condName (CondCode _ cond _) = cond
1263 condFloat (CondCode is_float _ _) = is_float
1264 condCode (CondCode _ _ code) = code
1267 Set up a condition code for a conditional branch.
1270 getCondCode :: StixTree -> UniqSM CondCode
1272 #if alpha_TARGET_ARCH
1273 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1274 #endif {- alpha_TARGET_ARCH -}
1275 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1277 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1278 -- yes, they really do seem to want exactly the same!
1280 getCondCode (StPrim primop [x, y])
1282 CharGtOp -> condIntCode GTT x y
1283 CharGeOp -> condIntCode GE x y
1284 CharEqOp -> condIntCode EQQ x y
1285 CharNeOp -> condIntCode NE x y
1286 CharLtOp -> condIntCode LTT x y
1287 CharLeOp -> condIntCode LE x y
1289 IntGtOp -> condIntCode GTT x y
1290 IntGeOp -> condIntCode GE x y
1291 IntEqOp -> condIntCode EQQ x y
1292 IntNeOp -> condIntCode NE x y
1293 IntLtOp -> condIntCode LTT x y
1294 IntLeOp -> condIntCode LE x y
1296 WordGtOp -> condIntCode GU x y
1297 WordGeOp -> condIntCode GEU x y
1298 WordEqOp -> condIntCode EQQ x y
1299 WordNeOp -> condIntCode NE x y
1300 WordLtOp -> condIntCode LU x y
1301 WordLeOp -> condIntCode LEU x y
1303 AddrGtOp -> condIntCode GU x y
1304 AddrGeOp -> condIntCode GEU x y
1305 AddrEqOp -> condIntCode EQQ x y
1306 AddrNeOp -> condIntCode NE x y
1307 AddrLtOp -> condIntCode LU x y
1308 AddrLeOp -> condIntCode LEU x y
1310 FloatGtOp -> condFltCode GTT x y
1311 FloatGeOp -> condFltCode GE x y
1312 FloatEqOp -> condFltCode EQQ x y
1313 FloatNeOp -> condFltCode NE x y
1314 FloatLtOp -> condFltCode LTT x y
1315 FloatLeOp -> condFltCode LE x y
1317 DoubleGtOp -> condFltCode GTT x y
1318 DoubleGeOp -> condFltCode GE x y
1319 DoubleEqOp -> condFltCode EQQ x y
1320 DoubleNeOp -> condFltCode NE x y
1321 DoubleLtOp -> condFltCode LTT x y
1322 DoubleLeOp -> condFltCode LE x y
1324 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1329 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1330 passed back up the tree.
1333 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1335 #if alpha_TARGET_ARCH
1336 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1337 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1338 #endif {- alpha_TARGET_ARCH -}
1340 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1341 #if i386_TARGET_ARCH
1343 condIntCode cond (StInd _ x) y
1345 = getAmode x `thenUs` \ amode ->
1347 code1 = amodeCode amode asmVoid
1348 y__2 = amodeAddr amode
1349 code__2 = asmParThen [code1] .
1350 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1352 returnUs (CondCode False cond code__2)
1355 imm__2 = case imm of Just x -> x
1357 condIntCode cond x (StInt 0)
1358 = getRegister x `thenUs` \ register1 ->
1359 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1361 code1 = registerCode register1 tmp1 asmVoid
1362 src1 = registerName register1 tmp1
1363 code__2 = asmParThen [code1] .
1364 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1366 returnUs (CondCode False cond code__2)
1368 condIntCode cond x y
1370 = getRegister x `thenUs` \ register1 ->
1371 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1373 code1 = registerCode register1 tmp1 asmVoid
1374 src1 = registerName register1 tmp1
1375 code__2 = asmParThen [code1] .
1376 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1378 returnUs (CondCode False cond code__2)
1381 imm__2 = case imm of Just x -> x
1383 condIntCode cond (StInd _ x) y
1384 = getAmode x `thenUs` \ amode ->
1385 getRegister y `thenUs` \ register2 ->
1386 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1388 code1 = amodeCode amode asmVoid
1389 src1 = amodeAddr amode
1390 code2 = registerCode register2 tmp2 asmVoid
1391 src2 = registerName register2 tmp2
1392 code__2 = asmParThen [code1, code2] .
1393 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1395 returnUs (CondCode False cond code__2)
1397 condIntCode cond y (StInd _ x)
1398 = getAmode x `thenUs` \ amode ->
1399 getRegister y `thenUs` \ register2 ->
1400 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1402 code1 = amodeCode amode asmVoid
1403 src1 = amodeAddr amode
1404 code2 = registerCode register2 tmp2 asmVoid
1405 src2 = registerName register2 tmp2
1406 code__2 = asmParThen [code1, code2] .
1407 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1409 returnUs (CondCode False cond code__2)
1411 condIntCode cond x y
1412 = getRegister x `thenUs` \ register1 ->
1413 getRegister y `thenUs` \ register2 ->
1414 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1415 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1417 code1 = registerCode register1 tmp1 asmVoid
1418 src1 = registerName register1 tmp1
1419 code2 = registerCode register2 tmp2 asmVoid
1420 src2 = registerName register2 tmp2
1421 code__2 = asmParThen [code1, code2] .
1422 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1424 returnUs (CondCode False cond code__2)
1428 condFltCode cond x (StDouble 0.0)
1429 = getRegister x `thenUs` \ register1 ->
1430 getNewRegNCG (registerRep register1)
1433 pk1 = registerRep register1
1434 code1 = registerCode register1 tmp1
1435 src1 = registerName register1 tmp1
1437 code__2 = asmParThen [code1 asmVoid] .
1438 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1440 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1441 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1445 returnUs (CondCode True (fix_FP_cond cond) code__2)
1447 condFltCode cond x y
1448 = getRegister x `thenUs` \ register1 ->
1449 getRegister y `thenUs` \ register2 ->
1450 getNewRegNCG (registerRep register1)
1452 getNewRegNCG (registerRep register2)
1455 pk1 = registerRep register1
1456 code1 = registerCode register1 tmp1
1457 src1 = registerName register1 tmp1
1459 code2 = registerCode register2 tmp2
1460 src2 = registerName register2 tmp2
1462 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1463 mkSeqInstrs [FUCOMPP,
1465 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1466 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1470 returnUs (CondCode True (fix_FP_cond cond) code__2)
1472 {- On the 486, the flags set by FP compare are the unsigned ones!
1473 (This looks like a HACK to me. WDP 96/03)
1476 fix_FP_cond :: Cond -> Cond
1478 fix_FP_cond GE = GEU
1479 fix_FP_cond GTT = GU
1480 fix_FP_cond LTT = LU
1481 fix_FP_cond LE = LEU
1482 fix_FP_cond any = any
1484 #endif {- i386_TARGET_ARCH -}
1485 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1486 #if sparc_TARGET_ARCH
1488 condIntCode cond x (StInt y)
1490 = getRegister x `thenUs` \ register ->
1491 getNewRegNCG IntRep `thenUs` \ tmp ->
1493 code = registerCode register tmp
1494 src1 = registerName register tmp
1495 src2 = ImmInt (fromInteger y)
1496 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1498 returnUs (CondCode False cond code__2)
1500 condIntCode cond x y
1501 = getRegister x `thenUs` \ register1 ->
1502 getRegister y `thenUs` \ register2 ->
1503 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1504 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1506 code1 = registerCode register1 tmp1 asmVoid
1507 src1 = registerName register1 tmp1
1508 code2 = registerCode register2 tmp2 asmVoid
1509 src2 = registerName register2 tmp2
1510 code__2 = asmParThen [code1, code2] .
1511 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1513 returnUs (CondCode False cond code__2)
1516 condFltCode cond x y
1517 = getRegister x `thenUs` \ register1 ->
1518 getRegister y `thenUs` \ register2 ->
1519 getNewRegNCG (registerRep register1)
1521 getNewRegNCG (registerRep register2)
1523 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1525 promote x = asmInstr (FxTOy F DF x tmp)
1527 pk1 = registerRep register1
1528 code1 = registerCode register1 tmp1
1529 src1 = registerName register1 tmp1
1531 pk2 = registerRep register2
1532 code2 = registerCode register2 tmp2
1533 src2 = registerName register2 tmp2
1537 asmParThen [code1 asmVoid, code2 asmVoid] .
1538 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1539 else if pk1 == FloatRep then
1540 asmParThen [code1 (promote src1), code2 asmVoid] .
1541 mkSeqInstr (FCMP True DF tmp src2)
1543 asmParThen [code1 asmVoid, code2 (promote src2)] .
1544 mkSeqInstr (FCMP True DF src1 tmp)
1546 returnUs (CondCode True cond code__2)
1548 #endif {- sparc_TARGET_ARCH -}
1551 %************************************************************************
1553 \subsection{Generating assignments}
1555 %************************************************************************
1557 Assignments are really at the heart of the whole code generation
1558 business. Almost all top-level nodes of any real importance are
1559 assignments, which correspond to loads, stores, or register transfers.
1560 If we're really lucky, some of the register transfers will go away,
1561 because we can use the destination register to complete the code
1562 generation for the right hand side. This only fails when the right
1563 hand side is forced into a fixed register (e.g. the result of a call).
1566 assignIntCode, assignFltCode
1567 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1569 #if alpha_TARGET_ARCH
1571 assignIntCode pk (StInd _ dst) src
1572 = getNewRegNCG IntRep `thenUs` \ tmp ->
1573 getAmode dst `thenUs` \ amode ->
1574 getRegister src `thenUs` \ register ->
1576 code1 = amodeCode amode asmVoid
1577 dst__2 = amodeAddr amode
1578 code2 = registerCode register tmp asmVoid
1579 src__2 = registerName register tmp
1580 sz = primRepToSize pk
1581 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1585 assignIntCode pk dst src
1586 = getRegister dst `thenUs` \ register1 ->
1587 getRegister src `thenUs` \ register2 ->
1589 dst__2 = registerName register1 zeroh
1590 code = registerCode register2 dst__2
1591 src__2 = registerName register2 dst__2
1592 code__2 = if isFixed register2
1593 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1598 #endif {- alpha_TARGET_ARCH -}
1599 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1600 #if i386_TARGET_ARCH
1602 assignIntCode pk (StInd _ dst) src
1603 = getAmode dst `thenUs` \ amode ->
1604 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1606 code1 = amodeCode amode asmVoid
1607 dst__2 = amodeAddr amode
1608 code__2 = asmParThen [code1, codesrc asmVoid] .
1609 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1615 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1619 = returnUs (asmParThen [], OpImm imm_op, L)
1622 imm_op = case imm of Just x -> x
1625 = getRegister op `thenUs` \ register ->
1626 getNewRegNCG (registerRep register)
1629 code = registerCode register tmp
1630 reg = registerName register tmp
1631 pk = registerRep register
1632 sz = primRepToSize pk
1634 returnUs (code, OpReg reg, sz)
1636 assignIntCode pk dst (StInd _ src)
1637 = getNewRegNCG IntRep `thenUs` \ tmp ->
1638 getAmode src `thenUs` \ amode ->
1639 getRegister dst `thenUs` \ register ->
1641 code1 = amodeCode amode asmVoid
1642 src__2 = amodeAddr amode
1643 code2 = registerCode register tmp asmVoid
1644 dst__2 = registerName register tmp
1645 sz = primRepToSize pk
1646 code__2 = asmParThen [code1, code2] .
1647 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1651 assignIntCode pk dst src
1652 = getRegister dst `thenUs` \ register1 ->
1653 getRegister src `thenUs` \ register2 ->
1654 getNewRegNCG IntRep `thenUs` \ tmp ->
1656 dst__2 = registerName register1 tmp
1657 code = registerCode register2 dst__2
1658 src__2 = registerName register2 dst__2
1659 code__2 = if isFixed register2 && dst__2 /= src__2
1660 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1665 #endif {- i386_TARGET_ARCH -}
1666 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1667 #if sparc_TARGET_ARCH
1669 assignIntCode pk (StInd _ dst) src
1670 = getNewRegNCG IntRep `thenUs` \ tmp ->
1671 getAmode dst `thenUs` \ amode ->
1672 getRegister src `thenUs` \ register ->
1674 code1 = amodeCode amode asmVoid
1675 dst__2 = amodeAddr amode
1676 code2 = registerCode register tmp asmVoid
1677 src__2 = registerName register tmp
1678 sz = primRepToSize pk
1679 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1683 assignIntCode pk dst src
1684 = getRegister dst `thenUs` \ register1 ->
1685 getRegister src `thenUs` \ register2 ->
1687 dst__2 = registerName register1 g0
1688 code = registerCode register2 dst__2
1689 src__2 = registerName register2 dst__2
1690 code__2 = if isFixed register2
1691 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1696 #endif {- sparc_TARGET_ARCH -}
1699 % --------------------------------
1700 Floating-point assignments:
1701 % --------------------------------
1703 #if alpha_TARGET_ARCH
1705 assignFltCode pk (StInd _ dst) src
1706 = getNewRegNCG pk `thenUs` \ tmp ->
1707 getAmode dst `thenUs` \ amode ->
1708 getRegister src `thenUs` \ register ->
1710 code1 = amodeCode amode asmVoid
1711 dst__2 = amodeAddr amode
1712 code2 = registerCode register tmp asmVoid
1713 src__2 = registerName register tmp
1714 sz = primRepToSize pk
1715 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1719 assignFltCode pk dst src
1720 = getRegister dst `thenUs` \ register1 ->
1721 getRegister src `thenUs` \ register2 ->
1723 dst__2 = registerName register1 zeroh
1724 code = registerCode register2 dst__2
1725 src__2 = registerName register2 dst__2
1726 code__2 = if isFixed register2
1727 then code . mkSeqInstr (FMOV src__2 dst__2)
1732 #endif {- alpha_TARGET_ARCH -}
1733 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1734 #if i386_TARGET_ARCH
1736 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1737 = getNewRegNCG IntRep `thenUs` \ tmp ->
1738 getAmode src `thenUs` \ amodesrc ->
1739 getAmode dst `thenUs` \ amodedst ->
1740 --getRegister src `thenUs` \ register ->
1742 codesrc1 = amodeCode amodesrc asmVoid
1743 addrsrc1 = amodeAddr amodesrc
1744 codedst1 = amodeCode amodedst asmVoid
1745 addrdst1 = amodeAddr amodedst
1746 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1747 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1749 code__2 = asmParThen [codesrc1, codedst1] .
1750 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1751 MOV L (OpReg tmp) (OpAddr addrdst1)]
1754 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1755 MOV L (OpReg tmp) (OpAddr addrdst2)]
1760 assignFltCode pk (StInd _ dst) src
1761 = --getNewRegNCG pk `thenUs` \ tmp ->
1762 getAmode dst `thenUs` \ amode ->
1763 getRegister src `thenUs` \ register ->
1765 sz = primRepToSize pk
1766 dst__2 = amodeAddr amode
1768 code1 = amodeCode amode asmVoid
1769 code2 = registerCode register {-tmp-}st0 asmVoid
1771 --src__2= registerName register tmp
1772 pk__2 = registerRep register
1773 sz__2 = primRepToSize pk__2
1775 code__2 = asmParThen [code1, code2] .
1776 mkSeqInstr (FSTP sz (OpAddr dst__2))
1780 assignFltCode pk dst src
1781 = getRegister dst `thenUs` \ register1 ->
1782 getRegister src `thenUs` \ register2 ->
1783 --getNewRegNCG (registerRep register2)
1784 -- `thenUs` \ tmp ->
1786 sz = primRepToSize pk
1787 dst__2 = registerName register1 st0 --tmp
1789 code = registerCode register2 dst__2
1790 src__2 = registerName register2 dst__2
1796 #endif {- i386_TARGET_ARCH -}
1797 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1798 #if sparc_TARGET_ARCH
1800 assignFltCode pk (StInd _ dst) src
1801 = getNewRegNCG pk `thenUs` \ tmp1 ->
1802 getAmode dst `thenUs` \ amode ->
1803 getRegister src `thenUs` \ register ->
1805 sz = primRepToSize pk
1806 dst__2 = amodeAddr amode
1808 code1 = amodeCode amode asmVoid
1809 code2 = registerCode register tmp1 asmVoid
1811 src__2 = registerName register tmp1
1812 pk__2 = registerRep register
1813 sz__2 = primRepToSize pk__2
1815 code__2 = asmParThen [code1, code2] .
1817 mkSeqInstr (ST sz src__2 dst__2)
1819 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1823 assignFltCode pk dst src
1824 = getRegister dst `thenUs` \ register1 ->
1825 getRegister src `thenUs` \ register2 ->
1827 pk__2 = registerRep register2
1828 sz__2 = primRepToSize pk__2
1830 getNewRegNCG pk__2 `thenUs` \ tmp ->
1832 sz = primRepToSize pk
1833 dst__2 = registerName register1 g0 -- must be Fixed
1836 reg__2 = if pk /= pk__2 then tmp else dst__2
1838 code = registerCode register2 reg__2
1840 src__2 = registerName register2 reg__2
1844 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1845 else if isFixed register2 then
1846 code . mkSeqInstr (FMOV sz src__2 dst__2)
1852 #endif {- sparc_TARGET_ARCH -}
1855 %************************************************************************
1857 \subsection{Generating an unconditional branch}
1859 %************************************************************************
1861 We accept two types of targets: an immediate CLabel or a tree that
1862 gets evaluated into a register. Any CLabels which are AsmTemporaries
1863 are assumed to be in the local block of code, close enough for a
1864 branch instruction. Other CLabels are assumed to be far away.
1866 (If applicable) Do not fill the delay slots here; you will confuse the
1870 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1872 #if alpha_TARGET_ARCH
1874 genJump (StCLbl lbl)
1875 | isAsmTemp lbl = returnInstr (BR target)
1876 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1878 target = ImmCLbl lbl
1881 = getRegister tree `thenUs` \ register ->
1882 getNewRegNCG PtrRep `thenUs` \ tmp ->
1884 dst = registerName register pv
1885 code = registerCode register pv
1886 target = registerName register pv
1888 if isFixed register then
1889 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1891 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1893 #endif {- alpha_TARGET_ARCH -}
1894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1895 #if i386_TARGET_ARCH
1898 genJump (StCLbl lbl)
1899 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1900 | otherwise = returnInstrs [JMP (OpImm target)]
1902 target = ImmCLbl lbl
1905 genJump (StInd pk mem)
1906 = getAmode mem `thenUs` \ amode ->
1908 code = amodeCode amode
1909 target = amodeAddr amode
1911 returnSeq code [JMP (OpAddr target)]
1915 = returnInstr (JMP (OpImm target))
1918 = getRegister tree `thenUs` \ register ->
1919 getNewRegNCG PtrRep `thenUs` \ tmp ->
1921 code = registerCode register tmp
1922 target = registerName register tmp
1924 returnSeq code [JMP (OpReg target)]
1927 target = case imm of Just x -> x
1929 #endif {- i386_TARGET_ARCH -}
1930 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1931 #if sparc_TARGET_ARCH
1933 genJump (StCLbl lbl)
1934 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1935 | otherwise = returnInstrs [CALL target 0 True, NOP]
1937 target = ImmCLbl lbl
1940 = getRegister tree `thenUs` \ register ->
1941 getNewRegNCG PtrRep `thenUs` \ tmp ->
1943 code = registerCode register tmp
1944 target = registerName register tmp
1946 returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
1948 #endif {- sparc_TARGET_ARCH -}
1951 %************************************************************************
1953 \subsection{Conditional jumps}
1955 %************************************************************************
1957 Conditional jumps are always to local labels, so we can use branch
1958 instructions. We peek at the arguments to decide what kind of
1961 ALPHA: For comparisons with 0, we're laughing, because we can just do
1962 the desired conditional branch.
1964 I386: First, we have to ensure that the condition
1965 codes are set according to the supplied comparison operation.
1967 SPARC: First, we have to ensure that the condition codes are set
1968 according to the supplied comparison operation. We generate slightly
1969 different code for floating point comparisons, because a floating
1970 point operation cannot directly precede a @BF@. We assume the worst
1971 and fill that slot with a @NOP@.
1973 SPARC: Do not fill the delay slots here; you will confuse the register
1978 :: CLabel -- the branch target
1979 -> StixTree -- the condition on which to branch
1980 -> UniqSM InstrBlock
1982 #if alpha_TARGET_ARCH
1984 genCondJump lbl (StPrim op [x, StInt 0])
1985 = getRegister x `thenUs` \ register ->
1986 getNewRegNCG (registerRep register)
1989 code = registerCode register tmp
1990 value = registerName register tmp
1991 pk = registerRep register
1992 target = ImmCLbl lbl
1994 returnSeq code [BI (cmpOp op) value target]
1996 cmpOp CharGtOp = GTT
1998 cmpOp CharEqOp = EQQ
2000 cmpOp CharLtOp = LTT
2009 cmpOp WordGeOp = ALWAYS
2010 cmpOp WordEqOp = EQQ
2012 cmpOp WordLtOp = NEVER
2013 cmpOp WordLeOp = EQQ
2015 cmpOp AddrGeOp = ALWAYS
2016 cmpOp AddrEqOp = EQQ
2018 cmpOp AddrLtOp = NEVER
2019 cmpOp AddrLeOp = EQQ
2021 genCondJump lbl (StPrim op [x, StDouble 0.0])
2022 = getRegister x `thenUs` \ register ->
2023 getNewRegNCG (registerRep register)
2026 code = registerCode register tmp
2027 value = registerName register tmp
2028 pk = registerRep register
2029 target = ImmCLbl lbl
2031 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2033 cmpOp FloatGtOp = GTT
2034 cmpOp FloatGeOp = GE
2035 cmpOp FloatEqOp = EQQ
2036 cmpOp FloatNeOp = NE
2037 cmpOp FloatLtOp = LTT
2038 cmpOp FloatLeOp = LE
2039 cmpOp DoubleGtOp = GTT
2040 cmpOp DoubleGeOp = GE
2041 cmpOp DoubleEqOp = EQQ
2042 cmpOp DoubleNeOp = NE
2043 cmpOp DoubleLtOp = LTT
2044 cmpOp DoubleLeOp = LE
2046 genCondJump lbl (StPrim op [x, y])
2048 = trivialFCode pr instr x y `thenUs` \ register ->
2049 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2051 code = registerCode register tmp
2052 result = registerName register tmp
2053 target = ImmCLbl lbl
2055 returnUs (code . mkSeqInstr (BF cond result target))
2057 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2059 fltCmpOp op = case op of
2073 (instr, cond) = case op of
2074 FloatGtOp -> (FCMP TF LE, EQQ)
2075 FloatGeOp -> (FCMP TF LTT, EQQ)
2076 FloatEqOp -> (FCMP TF EQQ, NE)
2077 FloatNeOp -> (FCMP TF EQQ, EQQ)
2078 FloatLtOp -> (FCMP TF LTT, NE)
2079 FloatLeOp -> (FCMP TF LE, NE)
2080 DoubleGtOp -> (FCMP TF LE, EQQ)
2081 DoubleGeOp -> (FCMP TF LTT, EQQ)
2082 DoubleEqOp -> (FCMP TF EQQ, NE)
2083 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2084 DoubleLtOp -> (FCMP TF LTT, NE)
2085 DoubleLeOp -> (FCMP TF LE, NE)
2087 genCondJump lbl (StPrim op [x, y])
2088 = trivialCode instr x y `thenUs` \ register ->
2089 getNewRegNCG IntRep `thenUs` \ tmp ->
2091 code = registerCode register tmp
2092 result = registerName register tmp
2093 target = ImmCLbl lbl
2095 returnUs (code . mkSeqInstr (BI cond result target))
2097 (instr, cond) = case op of
2098 CharGtOp -> (CMP LE, EQQ)
2099 CharGeOp -> (CMP LTT, EQQ)
2100 CharEqOp -> (CMP EQQ, NE)
2101 CharNeOp -> (CMP EQQ, EQQ)
2102 CharLtOp -> (CMP LTT, NE)
2103 CharLeOp -> (CMP LE, NE)
2104 IntGtOp -> (CMP LE, EQQ)
2105 IntGeOp -> (CMP LTT, EQQ)
2106 IntEqOp -> (CMP EQQ, NE)
2107 IntNeOp -> (CMP EQQ, EQQ)
2108 IntLtOp -> (CMP LTT, NE)
2109 IntLeOp -> (CMP LE, NE)
2110 WordGtOp -> (CMP ULE, EQQ)
2111 WordGeOp -> (CMP ULT, EQQ)
2112 WordEqOp -> (CMP EQQ, NE)
2113 WordNeOp -> (CMP EQQ, EQQ)
2114 WordLtOp -> (CMP ULT, NE)
2115 WordLeOp -> (CMP ULE, NE)
2116 AddrGtOp -> (CMP ULE, EQQ)
2117 AddrGeOp -> (CMP ULT, EQQ)
2118 AddrEqOp -> (CMP EQQ, NE)
2119 AddrNeOp -> (CMP EQQ, EQQ)
2120 AddrLtOp -> (CMP ULT, NE)
2121 AddrLeOp -> (CMP ULE, NE)
2123 #endif {- alpha_TARGET_ARCH -}
2124 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2125 #if i386_TARGET_ARCH
2127 genCondJump lbl bool
2128 = getCondCode bool `thenUs` \ condition ->
2130 code = condCode condition
2131 cond = condName condition
2132 target = ImmCLbl lbl
2134 returnSeq code [JXX cond lbl]
2136 #endif {- i386_TARGET_ARCH -}
2137 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2138 #if sparc_TARGET_ARCH
2140 genCondJump lbl bool
2141 = getCondCode bool `thenUs` \ condition ->
2143 code = condCode condition
2144 cond = condName condition
2145 target = ImmCLbl lbl
2148 if condFloat condition then
2149 [NOP, BF cond False target, NOP]
2151 [BI cond False target, NOP]
2154 #endif {- sparc_TARGET_ARCH -}
2157 %************************************************************************
2159 \subsection{Generating C calls}
2161 %************************************************************************
2163 Now the biggest nightmare---calls. Most of the nastiness is buried in
2164 @get_arg@, which moves the arguments to the correct registers/stack
2165 locations. Apart from that, the code is easy.
2167 (If applicable) Do not fill the delay slots here; you will confuse the
2172 :: FAST_STRING -- function to call
2173 -> PrimRep -- type of the result
2174 -> [StixTree] -- arguments (of mixed type)
2175 -> UniqSM InstrBlock
2177 #if alpha_TARGET_ARCH
2179 genCCall fn kind args
2180 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2181 `thenUs` \ ((unused,_), argCode) ->
2183 nRegs = length allArgRegs - length unused
2184 code = asmParThen (map ($ asmVoid) argCode)
2187 LDA pv (AddrImm (ImmLab (ptext fn))),
2188 JSR ra (AddrReg pv) nRegs,
2189 LDGP gp (AddrReg ra)]
2191 ------------------------
2192 {- Try to get a value into a specific register (or registers) for
2193 a call. The first 6 arguments go into the appropriate
2194 argument register (separate registers for integer and floating
2195 point arguments, but used in lock-step), and the remaining
2196 arguments are dumped to the stack, beginning at 0(sp). Our
2197 first argument is a pair of the list of remaining argument
2198 registers to be assigned for this call and the next stack
2199 offset to use for overflowing arguments. This way,
2200 @get_Arg@ can be applied to all of a call's arguments using
2204 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2205 -> StixTree -- Current argument
2206 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2208 -- We have to use up all of our argument registers first...
2210 get_arg ((iDst,fDst):dsts, offset) arg
2211 = getRegister arg `thenUs` \ register ->
2213 reg = if isFloatingRep pk then fDst else iDst
2214 code = registerCode register reg
2215 src = registerName register reg
2216 pk = registerRep register
2219 if isFloatingRep pk then
2220 ((dsts, offset), if isFixed register then
2221 code . mkSeqInstr (FMOV src fDst)
2224 ((dsts, offset), if isFixed register then
2225 code . mkSeqInstr (OR src (RIReg src) iDst)
2228 -- Once we have run out of argument registers, we move to the
2231 get_arg ([], offset) arg
2232 = getRegister arg `thenUs` \ register ->
2233 getNewRegNCG (registerRep register)
2236 code = registerCode register tmp
2237 src = registerName register tmp
2238 pk = registerRep register
2239 sz = primRepToSize pk
2241 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2243 #endif {- alpha_TARGET_ARCH -}
2244 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2245 #if i386_TARGET_ARCH
2247 genCCall fn kind [StInt i]
2248 | fn == SLIT ("PerformGC_wrapper")
2249 = getUniqLabelNCG `thenUs` \ lbl ->
2251 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2252 MOV L (OpImm (ImmCLbl lbl))
2253 -- this is hardwired
2254 (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
2255 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2260 genCCall fn kind args
2261 = mapUs get_call_arg args `thenUs` \ argCode ->
2264 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
2265 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2268 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2269 call = [CALL fn__2 -- ,
2270 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
2271 -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2274 returnSeq (code1 . code2) call
2276 -- function names that begin with '.' are assumed to be special
2277 -- internally generated names like '.mul,' which don't get an
2278 -- underscore prefix
2279 -- ToDo:needed (WDP 96/03) ???
2280 fn__2 = case (_HEAD_ fn) of
2281 '.' -> ImmLit (ptext fn)
2282 _ -> ImmLab (ptext fn)
2285 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2288 = get_op arg `thenUs` \ (code, op, sz) ->
2289 returnUs (code . mkSeqInstr (PUSH sz op))
2294 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2297 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2299 get_op (StInd pk mem)
2300 = getAmode mem `thenUs` \ amode ->
2302 code = amodeCode amode --asmVoid
2303 addr = amodeAddr amode
2304 sz = primRepToSize pk
2306 returnUs (code, OpAddr addr, sz)
2309 = getRegister op `thenUs` \ register ->
2310 getNewRegNCG (registerRep register)
2313 code = registerCode register tmp
2314 reg = registerName register tmp
2315 pk = registerRep register
2316 sz = primRepToSize pk
2318 returnUs (code, OpReg reg, sz)
2320 #endif {- i386_TARGET_ARCH -}
2321 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2322 #if sparc_TARGET_ARCH
2324 genCCall fn kind args
2325 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2326 `thenUs` \ ((unused,_), argCode) ->
2328 nRegs = length allArgRegs - length unused
2329 call = CALL fn__2 nRegs False
2330 code = asmParThen (map ($ asmVoid) argCode)
2332 returnSeq code [call, NOP]
2334 -- function names that begin with '.' are assumed to be special
2335 -- internally generated names like '.mul,' which don't get an
2336 -- underscore prefix
2337 -- ToDo:needed (WDP 96/03) ???
2338 fn__2 = case (_HEAD_ fn) of
2339 '.' -> ImmLit (ptext fn)
2340 _ -> ImmLab (ptext fn)
2342 ------------------------------------
2343 {- Try to get a value into a specific register (or registers) for
2344 a call. The SPARC calling convention is an absolute
2345 nightmare. The first 6x32 bits of arguments are mapped into
2346 %o0 through %o5, and the remaining arguments are dumped to the
2347 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2348 first argument is a pair of the list of remaining argument
2349 registers to be assigned for this call and the next stack
2350 offset to use for overflowing arguments. This way,
2351 @get_arg@ can be applied to all of a call's arguments using
2355 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2356 -> StixTree -- Current argument
2357 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2359 -- We have to use up all of our argument registers first...
2361 get_arg (dst:dsts, offset) arg
2362 = getRegister arg `thenUs` \ register ->
2363 getNewRegNCG (registerRep register)
2366 reg = if isFloatingRep pk then tmp else dst
2367 code = registerCode register reg
2368 src = registerName register reg
2369 pk = registerRep register
2371 returnUs (case pk of
2374 [] -> (([], offset + 1), code . mkSeqInstrs [
2375 -- conveniently put the second part in the right stack
2376 -- location, and load the first part into %o5
2377 ST DF src (spRel (offset - 1)),
2378 LD W (spRel (offset - 1)) dst])
2379 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2380 ST DF src (spRel (-2)),
2381 LD W (spRel (-2)) dst,
2382 LD W (spRel (-1)) dst__2])
2383 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2384 ST F src (spRel (-2)),
2385 LD W (spRel (-2)) dst])
2386 _ -> ((dsts, offset), if isFixed register then
2387 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2390 -- Once we have run out of argument registers, we move to the
2393 get_arg ([], offset) arg
2394 = getRegister arg `thenUs` \ register ->
2395 getNewRegNCG (registerRep register)
2398 code = registerCode register tmp
2399 src = registerName register tmp
2400 pk = registerRep register
2401 sz = primRepToSize pk
2402 words = if pk == DoubleRep then 2 else 1
2404 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2406 #endif {- sparc_TARGET_ARCH -}
2409 %************************************************************************
2411 \subsection{Support bits}
2413 %************************************************************************
2415 %************************************************************************
2417 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2419 %************************************************************************
2421 Turn those condition codes into integers now (when they appear on
2422 the right hand side of an assignment).
2424 (If applicable) Do not fill the delay slots here; you will confuse the
2428 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2430 #if alpha_TARGET_ARCH
2431 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2432 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2433 #endif {- alpha_TARGET_ARCH -}
2435 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2436 #if i386_TARGET_ARCH
2439 = condIntCode cond x y `thenUs` \ condition ->
2440 getNewRegNCG IntRep `thenUs` \ tmp ->
2441 --getRegister dst `thenUs` \ register ->
2443 --code2 = registerCode register tmp asmVoid
2444 --dst__2 = registerName register tmp
2445 code = condCode condition
2446 cond = condName condition
2447 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2448 code__2 dst = code . mkSeqInstrs [
2449 SETCC cond (OpReg tmp),
2450 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2451 MOV L (OpReg tmp) (OpReg dst)]
2453 returnUs (Any IntRep code__2)
2456 = getUniqLabelNCG `thenUs` \ lbl1 ->
2457 getUniqLabelNCG `thenUs` \ lbl2 ->
2458 condFltCode cond x y `thenUs` \ condition ->
2460 code = condCode condition
2461 cond = condName condition
2462 code__2 dst = code . mkSeqInstrs [
2464 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2467 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2470 returnUs (Any IntRep code__2)
2472 #endif {- i386_TARGET_ARCH -}
2473 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2474 #if sparc_TARGET_ARCH
2476 condIntReg EQQ x (StInt 0)
2477 = getRegister x `thenUs` \ register ->
2478 getNewRegNCG IntRep `thenUs` \ tmp ->
2480 code = registerCode register tmp
2481 src = registerName register tmp
2482 code__2 dst = code . mkSeqInstrs [
2483 SUB False True g0 (RIReg src) g0,
2484 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2486 returnUs (Any IntRep code__2)
2489 = getRegister x `thenUs` \ register1 ->
2490 getRegister y `thenUs` \ register2 ->
2491 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2492 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2494 code1 = registerCode register1 tmp1 asmVoid
2495 src1 = registerName register1 tmp1
2496 code2 = registerCode register2 tmp2 asmVoid
2497 src2 = registerName register2 tmp2
2498 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2499 XOR False src1 (RIReg src2) dst,
2500 SUB False True g0 (RIReg dst) g0,
2501 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2503 returnUs (Any IntRep code__2)
2505 condIntReg NE x (StInt 0)
2506 = getRegister x `thenUs` \ register ->
2507 getNewRegNCG IntRep `thenUs` \ tmp ->
2509 code = registerCode register tmp
2510 src = registerName register tmp
2511 code__2 dst = code . mkSeqInstrs [
2512 SUB False True g0 (RIReg src) g0,
2513 ADD True False g0 (RIImm (ImmInt 0)) dst]
2515 returnUs (Any IntRep code__2)
2518 = getRegister x `thenUs` \ register1 ->
2519 getRegister y `thenUs` \ register2 ->
2520 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2521 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2523 code1 = registerCode register1 tmp1 asmVoid
2524 src1 = registerName register1 tmp1
2525 code2 = registerCode register2 tmp2 asmVoid
2526 src2 = registerName register2 tmp2
2527 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2528 XOR False src1 (RIReg src2) dst,
2529 SUB False True g0 (RIReg dst) g0,
2530 ADD True False g0 (RIImm (ImmInt 0)) dst]
2532 returnUs (Any IntRep code__2)
2535 = getUniqLabelNCG `thenUs` \ lbl1 ->
2536 getUniqLabelNCG `thenUs` \ lbl2 ->
2537 condIntCode cond x y `thenUs` \ condition ->
2539 code = condCode condition
2540 cond = condName condition
2541 code__2 dst = code . mkSeqInstrs [
2542 BI cond False (ImmCLbl lbl1), NOP,
2543 OR False g0 (RIImm (ImmInt 0)) dst,
2544 BI ALWAYS False (ImmCLbl lbl2), NOP,
2546 OR False g0 (RIImm (ImmInt 1)) dst,
2549 returnUs (Any IntRep code__2)
2552 = getUniqLabelNCG `thenUs` \ lbl1 ->
2553 getUniqLabelNCG `thenUs` \ lbl2 ->
2554 condFltCode cond x y `thenUs` \ condition ->
2556 code = condCode condition
2557 cond = condName condition
2558 code__2 dst = code . mkSeqInstrs [
2560 BF cond False (ImmCLbl lbl1), NOP,
2561 OR False g0 (RIImm (ImmInt 0)) dst,
2562 BI ALWAYS False (ImmCLbl lbl2), NOP,
2564 OR False g0 (RIImm (ImmInt 1)) dst,
2567 returnUs (Any IntRep code__2)
2569 #endif {- sparc_TARGET_ARCH -}
2572 %************************************************************************
2574 \subsubsection{@trivial*Code@: deal with trivial instructions}
2576 %************************************************************************
2578 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2579 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2580 for constants on the right hand side, because that's where the generic
2581 optimizer will have put them.
2583 Similarly, for unary instructions, we don't have to worry about
2584 matching an StInt as the argument, because genericOpt will already
2585 have handled the constant-folding.
2589 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2590 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2591 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2593 -> StixTree -> StixTree -- the two arguments
2598 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2599 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2601 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2602 (Size -> Operand -> Instr)
2603 -> (Size -> Operand -> Instr) {-reversed instr-}
2605 -> Instr {-reversed instr: pop-}
2607 -> StixTree -> StixTree -- the two arguments
2611 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2612 ,IF_ARCH_i386 ((Operand -> Instr)
2613 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2615 -> StixTree -- the one argument
2620 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2621 ,IF_ARCH_i386 (Instr
2622 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2624 -> StixTree -- the one argument
2627 #if alpha_TARGET_ARCH
2629 trivialCode instr x (StInt y)
2631 = getRegister x `thenUs` \ register ->
2632 getNewRegNCG IntRep `thenUs` \ tmp ->
2634 code = registerCode register tmp
2635 src1 = registerName register tmp
2636 src2 = ImmInt (fromInteger y)
2637 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2639 returnUs (Any IntRep code__2)
2641 trivialCode instr x y
2642 = getRegister x `thenUs` \ register1 ->
2643 getRegister y `thenUs` \ register2 ->
2644 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2645 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2647 code1 = registerCode register1 tmp1 asmVoid
2648 src1 = registerName register1 tmp1
2649 code2 = registerCode register2 tmp2 asmVoid
2650 src2 = registerName register2 tmp2
2651 code__2 dst = asmParThen [code1, code2] .
2652 mkSeqInstr (instr src1 (RIReg src2) dst)
2654 returnUs (Any IntRep code__2)
2657 trivialUCode instr x
2658 = getRegister x `thenUs` \ register ->
2659 getNewRegNCG IntRep `thenUs` \ tmp ->
2661 code = registerCode register tmp
2662 src = registerName register tmp
2663 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2665 returnUs (Any IntRep code__2)
2668 trivialFCode _ instr x y
2669 = getRegister x `thenUs` \ register1 ->
2670 getRegister y `thenUs` \ register2 ->
2671 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2672 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2674 code1 = registerCode register1 tmp1
2675 src1 = registerName register1 tmp1
2677 code2 = registerCode register2 tmp2
2678 src2 = registerName register2 tmp2
2680 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2681 mkSeqInstr (instr src1 src2 dst)
2683 returnUs (Any DoubleRep code__2)
2685 trivialUFCode _ instr x
2686 = getRegister x `thenUs` \ register ->
2687 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2689 code = registerCode register tmp
2690 src = registerName register tmp
2691 code__2 dst = code . mkSeqInstr (instr src dst)
2693 returnUs (Any DoubleRep code__2)
2695 #endif {- alpha_TARGET_ARCH -}
2696 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2697 #if i386_TARGET_ARCH
2699 trivialCode instr x y
2701 = getRegister x `thenUs` \ register1 ->
2702 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2704 fixedname = registerName register1 eax
2705 code__2 dst = let code1 = registerCode register1 dst
2706 src1 = registerName register1 dst
2708 if isFixed register1 && src1 /= dst
2709 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2710 instr (OpImm imm__2) (OpReg dst)]
2712 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2714 returnUs (Any IntRep code__2)
2717 imm__2 = case imm of Just x -> x
2719 trivialCode instr x y
2721 = getRegister y `thenUs` \ register1 ->
2722 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2724 fixedname = registerName register1 eax
2725 code__2 dst = let code1 = registerCode register1 dst
2726 src1 = registerName register1 dst
2728 if isFixed register1 && src1 /= dst
2729 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2730 instr (OpImm imm__2) (OpReg dst)]
2732 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2734 returnUs (Any IntRep code__2)
2737 imm__2 = case imm of Just x -> x
2739 trivialCode instr x (StInd pk mem)
2740 = getRegister x `thenUs` \ register ->
2741 --getNewRegNCG IntRep `thenUs` \ tmp ->
2742 getAmode mem `thenUs` \ amode ->
2744 fixedname = registerName register eax
2745 code2 = amodeCode amode asmVoid
2746 src2 = amodeAddr amode
2747 code__2 dst = let code1 = registerCode register dst asmVoid
2748 src1 = registerName register dst
2749 in asmParThen [code1, code2] .
2750 if isFixed register && src1 /= dst
2751 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2752 instr (OpAddr src2) (OpReg dst)]
2754 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2756 returnUs (Any pk code__2)
2758 trivialCode instr (StInd pk mem) y
2759 = getRegister y `thenUs` \ register ->
2760 --getNewRegNCG IntRep `thenUs` \ tmp ->
2761 getAmode mem `thenUs` \ amode ->
2763 fixedname = registerName register eax
2764 code2 = amodeCode amode asmVoid
2765 src2 = amodeAddr amode
2767 code1 = registerCode register dst asmVoid
2768 src1 = registerName register dst
2769 in asmParThen [code1, code2] .
2770 if isFixed register && src1 /= dst
2771 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2772 instr (OpAddr src2) (OpReg dst)]
2774 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2776 returnUs (Any pk code__2)
2778 trivialCode instr x y
2779 = getRegister x `thenUs` \ register1 ->
2780 getRegister y `thenUs` \ register2 ->
2781 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2782 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2784 fixedname = registerName register1 eax
2785 code2 = registerCode register2 tmp2 asmVoid
2786 src2 = registerName register2 tmp2
2788 code1 = registerCode register1 dst asmVoid
2789 src1 = registerName register1 dst
2790 in asmParThen [code1, code2] .
2791 if isFixed register1 && src1 /= dst
2792 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2793 instr (OpReg src2) (OpReg dst)]
2795 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2797 returnUs (Any IntRep code__2)
2800 trivialUCode instr x
2801 = getRegister x `thenUs` \ register ->
2802 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2804 -- fixedname = registerName register eax
2806 code = registerCode register dst
2807 src = registerName register dst
2808 in code . if isFixed register && dst /= src
2809 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2811 else mkSeqInstr (instr (OpReg src))
2813 returnUs (Any IntRep code__2)
2816 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2817 = getRegister y `thenUs` \ register2 ->
2818 --getNewRegNCG (registerRep register2)
2819 -- `thenUs` \ tmp2 ->
2820 getAmode mem `thenUs` \ amode ->
2822 code1 = amodeCode amode
2823 src1 = amodeAddr amode
2826 code2 = registerCode register2 dst
2827 src2 = registerName register2 dst
2828 in asmParThen [code1 asmVoid,code2 asmVoid] .
2829 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2831 returnUs (Any pk code__2)
2833 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2834 = getRegister x `thenUs` \ register1 ->
2835 --getNewRegNCG (registerRep register1)
2836 -- `thenUs` \ tmp1 ->
2837 getAmode mem `thenUs` \ amode ->
2839 code2 = amodeCode amode
2840 src2 = amodeAddr amode
2843 code1 = registerCode register1 dst
2844 src1 = registerName register1 dst
2845 in asmParThen [code2 asmVoid,code1 asmVoid] .
2846 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2848 returnUs (Any pk code__2)
2850 trivialFCode pk _ _ _ instrpr x y
2851 = getRegister x `thenUs` \ register1 ->
2852 getRegister y `thenUs` \ register2 ->
2853 --getNewRegNCG (registerRep register1)
2854 -- `thenUs` \ tmp1 ->
2855 --getNewRegNCG (registerRep register2)
2856 -- `thenUs` \ tmp2 ->
2857 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2859 pk1 = registerRep register1
2860 code1 = registerCode register1 st0 --tmp1
2861 src1 = registerName register1 st0 --tmp1
2863 pk2 = registerRep register2
2866 code2 = registerCode register2 dst
2867 src2 = registerName register2 dst
2868 in asmParThen [code1 asmVoid, code2 asmVoid] .
2871 returnUs (Any pk1 code__2)
2874 trivialUFCode pk instr (StInd pk' mem)
2875 = getAmode mem `thenUs` \ amode ->
2877 code = amodeCode amode
2878 src = amodeAddr amode
2879 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2882 returnUs (Any pk code__2)
2884 trivialUFCode pk instr x
2885 = getRegister x `thenUs` \ register ->
2886 --getNewRegNCG pk `thenUs` \ tmp ->
2889 code = registerCode register dst
2890 src = registerName register dst
2891 in code . mkSeqInstrs [instr]
2893 returnUs (Any pk code__2)
2895 #endif {- i386_TARGET_ARCH -}
2896 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2897 #if sparc_TARGET_ARCH
2899 trivialCode instr x (StInt y)
2901 = getRegister x `thenUs` \ register ->
2902 getNewRegNCG IntRep `thenUs` \ tmp ->
2904 code = registerCode register tmp
2905 src1 = registerName register tmp
2906 src2 = ImmInt (fromInteger y)
2907 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2909 returnUs (Any IntRep code__2)
2911 trivialCode instr x y
2912 = getRegister x `thenUs` \ register1 ->
2913 getRegister y `thenUs` \ register2 ->
2914 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2915 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2917 code1 = registerCode register1 tmp1 asmVoid
2918 src1 = registerName register1 tmp1
2919 code2 = registerCode register2 tmp2 asmVoid
2920 src2 = registerName register2 tmp2
2921 code__2 dst = asmParThen [code1, code2] .
2922 mkSeqInstr (instr src1 (RIReg src2) dst)
2924 returnUs (Any IntRep code__2)
2927 trivialFCode pk instr x y
2928 = getRegister x `thenUs` \ register1 ->
2929 getRegister y `thenUs` \ register2 ->
2930 getNewRegNCG (registerRep register1)
2932 getNewRegNCG (registerRep register2)
2934 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2936 promote x = asmInstr (FxTOy F DF x tmp)
2938 pk1 = registerRep register1
2939 code1 = registerCode register1 tmp1
2940 src1 = registerName register1 tmp1
2942 pk2 = registerRep register2
2943 code2 = registerCode register2 tmp2
2944 src2 = registerName register2 tmp2
2948 asmParThen [code1 asmVoid, code2 asmVoid] .
2949 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2950 else if pk1 == FloatRep then
2951 asmParThen [code1 (promote src1), code2 asmVoid] .
2952 mkSeqInstr (instr DF tmp src2 dst)
2954 asmParThen [code1 asmVoid, code2 (promote src2)] .
2955 mkSeqInstr (instr DF src1 tmp dst)
2957 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2960 trivialUCode instr x
2961 = getRegister x `thenUs` \ register ->
2962 getNewRegNCG IntRep `thenUs` \ tmp ->
2964 code = registerCode register tmp
2965 src = registerName register tmp
2966 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2968 returnUs (Any IntRep code__2)
2971 trivialUFCode pk instr x
2972 = getRegister x `thenUs` \ register ->
2973 getNewRegNCG pk `thenUs` \ tmp ->
2975 code = registerCode register tmp
2976 src = registerName register tmp
2977 code__2 dst = code . mkSeqInstr (instr src dst)
2979 returnUs (Any pk code__2)
2981 #endif {- sparc_TARGET_ARCH -}
2984 %************************************************************************
2986 \subsubsection{Coercing to/from integer/floating-point...}
2988 %************************************************************************
2990 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2991 to be generated. Here we just change the type on the Register passed
2992 on up. The code is machine-independent.
2994 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2995 conversions. We have to store temporaries in memory to move
2996 between the integer and the floating point register sets.
2999 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3000 coerceFltCode :: StixTree -> UniqSM Register
3002 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3003 coerceFP2Int :: StixTree -> UniqSM Register
3006 = getRegister x `thenUs` \ register ->
3009 Fixed _ reg code -> Fixed pk reg code
3010 Any _ code -> Any pk code
3015 = getRegister x `thenUs` \ register ->
3018 Fixed _ reg code -> Fixed DoubleRep reg code
3019 Any _ code -> Any DoubleRep code
3024 #if alpha_TARGET_ARCH
3027 = getRegister x `thenUs` \ register ->
3028 getNewRegNCG IntRep `thenUs` \ reg ->
3030 code = registerCode register reg
3031 src = registerName register reg
3033 code__2 dst = code . mkSeqInstrs [
3035 LD TF dst (spRel 0),
3038 returnUs (Any DoubleRep code__2)
3042 = getRegister x `thenUs` \ register ->
3043 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3045 code = registerCode register tmp
3046 src = registerName register tmp
3048 code__2 dst = code . mkSeqInstrs [
3050 ST TF tmp (spRel 0),
3053 returnUs (Any IntRep code__2)
3055 #endif {- alpha_TARGET_ARCH -}
3056 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3057 #if i386_TARGET_ARCH
3060 = getRegister x `thenUs` \ register ->
3061 getNewRegNCG IntRep `thenUs` \ reg ->
3063 code = registerCode register reg
3064 src = registerName register reg
3066 code__2 dst = code . mkSeqInstrs [
3067 -- to fix: should spill instead of using R1
3068 MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
3069 FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3071 returnUs (Any pk code__2)
3075 = getRegister x `thenUs` \ register ->
3076 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3078 code = registerCode register tmp
3079 src = registerName register tmp
3080 pk = registerRep register
3083 in code . mkSeqInstrs [
3085 FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
3086 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3088 returnUs (Any IntRep code__2)
3090 #endif {- i386_TARGET_ARCH -}
3091 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3092 #if sparc_TARGET_ARCH
3095 = getRegister x `thenUs` \ register ->
3096 getNewRegNCG IntRep `thenUs` \ reg ->
3098 code = registerCode register reg
3099 src = registerName register reg
3101 code__2 dst = code . mkSeqInstrs [
3102 ST W src (spRel (-2)),
3103 LD W (spRel (-2)) dst,
3104 FxTOy W (primRepToSize pk) dst dst]
3106 returnUs (Any pk code__2)
3110 = getRegister x `thenUs` \ register ->
3111 getNewRegNCG IntRep `thenUs` \ reg ->
3112 getNewRegNCG FloatRep `thenUs` \ tmp ->
3114 code = registerCode register reg
3115 src = registerName register reg
3116 pk = registerRep register
3118 code__2 dst = code . mkSeqInstrs [
3119 FxTOy (primRepToSize pk) W src tmp,
3120 ST W tmp (spRel (-2)),
3121 LD W (spRel (-2)) dst]
3123 returnUs (Any IntRep code__2)
3125 #endif {- sparc_TARGET_ARCH -}
3128 %************************************************************************
3130 \subsubsection{Coercing integer to @Char@...}
3132 %************************************************************************
3134 Integer to character conversion. Where applicable, we try to do this
3135 in one step if the original object is in memory.
3138 chrCode :: StixTree -> UniqSM Register
3140 #if alpha_TARGET_ARCH
3143 = getRegister x `thenUs` \ register ->
3144 getNewRegNCG IntRep `thenUs` \ reg ->
3146 code = registerCode register reg
3147 src = registerName register reg
3148 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3150 returnUs (Any IntRep code__2)
3152 #endif {- alpha_TARGET_ARCH -}
3153 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3154 #if i386_TARGET_ARCH
3157 = getRegister x `thenUs` \ register ->
3158 --getNewRegNCG IntRep `thenUs` \ reg ->
3160 fixedname = registerName register eax
3162 code = registerCode register dst
3163 src = registerName register dst
3165 if isFixed register && src /= dst
3166 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3167 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3168 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3170 returnUs (Any IntRep code__2)
3172 #endif {- i386_TARGET_ARCH -}
3173 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3174 #if sparc_TARGET_ARCH
3176 chrCode (StInd pk mem)
3177 = getAmode mem `thenUs` \ amode ->
3179 code = amodeCode amode
3180 src = amodeAddr amode
3181 src_off = addrOffset src 3
3182 src__2 = case src_off of Just x -> x
3183 code__2 dst = if maybeToBool src_off then
3184 code . mkSeqInstr (LD BU src__2 dst)
3186 code . mkSeqInstrs [
3187 LD (primRepToSize pk) src dst,
3188 AND False dst (RIImm (ImmInt 255)) dst]
3190 returnUs (Any pk code__2)
3193 = getRegister x `thenUs` \ register ->
3194 getNewRegNCG IntRep `thenUs` \ reg ->
3196 code = registerCode register reg
3197 src = registerName register reg
3198 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3200 returnUs (Any IntRep code__2)
3202 #endif {- sparc_TARGET_ARCH -}
3205 %************************************************************************
3207 \subsubsection{Absolute value on integers}
3209 %************************************************************************
3211 Absolute value on integers, mostly for gmp size check macros. Again,
3212 the argument cannot be an StInt, because genericOpt already folded
3215 If applicable, do not fill the delay slots here; you will confuse the
3219 absIntCode :: StixTree -> UniqSM Register
3221 #if alpha_TARGET_ARCH
3222 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3223 #endif {- alpha_TARGET_ARCH -}
3225 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3226 #if i386_TARGET_ARCH
3229 = getRegister x `thenUs` \ register ->
3230 --getNewRegNCG IntRep `thenUs` \ reg ->
3231 getUniqLabelNCG `thenUs` \ lbl ->
3233 code__2 dst = let code = registerCode register dst
3234 src = registerName register dst
3235 in code . if isFixed register && dst /= src
3236 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3237 TEST L (OpReg dst) (OpReg dst),
3241 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3246 returnUs (Any IntRep code__2)
3248 #endif {- i386_TARGET_ARCH -}
3249 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3250 #if sparc_TARGET_ARCH
3253 = getRegister x `thenUs` \ register ->
3254 getNewRegNCG IntRep `thenUs` \ reg ->
3255 getUniqLabelNCG `thenUs` \ lbl ->
3257 code = registerCode register reg
3258 src = registerName register reg
3259 code__2 dst = code . mkSeqInstrs [
3260 SUB False True g0 (RIReg src) dst,
3261 BI GE False (ImmCLbl lbl), NOP,
3262 OR False g0 (RIReg src) dst,
3265 returnUs (Any IntRep code__2)
3267 #endif {- sparc_TARGET_ARCH -}