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
22 import AbsCSyn ( MagicId )
23 import AbsCUtils ( magicIdPrimRep )
24 import CLabel ( isAsmTemp, CLabel )
25 import Maybes ( maybeToBool, expectJust )
26 import OrdList -- quite a bit of it
27 import Outputable ( PprStyle(..) )
28 import Pretty ( ptext, rational )
29 import PrimRep ( isFloatingRep, PrimRep(..) )
30 import PrimOp ( PrimOp(..), showPrimOp )
31 import Stix ( getUniqLabelNCG, StixTree(..),
32 StixReg(..), CodeSegment(..)
34 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
35 mapAccumLUs, SYN_IE(UniqSM)
37 import Util ( panic, assertPanic )
40 Code extractor for an entire stix tree---stix statement level.
43 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
45 stmt2Instrs stmt = case stmt of
46 StComment s -> returnInstr (COMMENT s)
47 StSegment seg -> returnInstr (SEGMENT seg)
48 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
49 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
50 StLabel lab -> returnInstr (LABEL lab)
52 StJump arg -> genJump arg
53 StCondJump lab arg -> genCondJump lab arg
54 StCall fn VoidRep args -> genCCall fn VoidRep args
57 | isFloatingRep pk -> assignFltCode pk dst src
58 | otherwise -> assignIntCode pk dst src
61 -- When falling through on the Alpha, we still have to load pv
62 -- with the address of the next routine, so that it can load gp.
63 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
67 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
68 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
69 (foldr1 (.) codes xs))
71 getData :: StixTree -> UniqSM (InstrBlock, Imm)
73 getData (StInt i) = returnUs (id, ImmInteger i)
74 getData (StDouble d) = returnUs (id, dblImmLit d)
75 getData (StLitLbl s) = returnUs (id, ImmLab s)
76 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
77 getData (StCLbl l) = returnUs (id, ImmCLbl l)
78 getData (StString s) =
79 getUniqLabelNCG `thenUs` \ lbl ->
80 returnUs (mkSeqInstrs [LABEL lbl,
81 ASCII True (_UNPK_ s)],
85 %************************************************************************
87 \subsection{General things for putting together code sequences}
89 %************************************************************************
92 type InstrList = OrdList Instr
93 type InstrBlock = InstrList -> InstrList
98 asmInstr :: Instr -> InstrList
99 asmInstr i = mkUnitList i
101 asmSeq :: [Instr] -> InstrList
102 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
104 asmParThen :: [InstrList] -> InstrBlock
105 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
107 returnInstr :: Instr -> UniqSM InstrBlock
108 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
110 returnInstrs :: [Instr] -> UniqSM InstrBlock
111 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
113 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
114 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
116 mkSeqInstr :: Instr -> InstrBlock
117 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
119 mkSeqInstrs :: [Instr] -> InstrBlock
120 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
124 mangleIndexTree :: StixTree -> StixTree
126 mangleIndexTree (StIndex pk base (StInt i))
127 = StPrim IntAddOp [base, off]
129 off = StInt (i * sizeOf pk)
131 #ifndef i386_TARGET_ARCH
132 mangleIndexTree (StIndex pk base off)
133 = StPrim IntAddOp [base,
139 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
140 StPrim SllOp [off, StInt s]
143 shift DoubleRep = 3::Integer
144 shift _ = IF_ARCH_alpha(3,2)
146 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
147 -- that do include the size of the primitive kind we're addressing. When StIndex
148 -- is expanded to actual code, the index (in units) is by the above code approp.
149 -- shifted to get the no. of bytes. Since Address amodes do contain size info
150 -- explicitly, we disable the shifting for x86s.
151 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
157 maybeImm :: StixTree -> Maybe Imm
159 maybeImm (StLitLbl s) = Just (ImmLab s)
160 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
161 maybeImm (StCLbl l) = Just (ImmCLbl l)
164 | i >= toInteger minInt && i <= toInteger maxInt
165 = Just (ImmInt (fromInteger i))
167 = Just (ImmInteger i)
172 %************************************************************************
174 \subsection{The @Register@ type}
176 %************************************************************************
178 @Register@s passed up the tree. If the stix code forces the register
179 to live in a pre-decided machine register, it comes out as @Fixed@;
180 otherwise, it comes out as @Any@, and the parent can decide which
181 register to put it in.
185 = Fixed PrimRep Reg InstrBlock
186 | Any PrimRep (Reg -> InstrBlock)
188 registerCode :: Register -> Reg -> InstrBlock
189 registerCode (Fixed _ _ code) reg = code
190 registerCode (Any _ code) reg = code reg
192 registerName :: Register -> Reg -> Reg
193 registerName (Fixed _ reg _) _ = reg
194 registerName (Any _ _) reg = reg
196 registerRep :: Register -> PrimRep
197 registerRep (Fixed pk _ _) = pk
198 registerRep (Any pk _) = pk
200 isFixed :: Register -> Bool
201 isFixed (Fixed _ _ _) = True
202 isFixed (Any _ _) = False
205 Generate code to get a subtree into a @Register@:
207 getRegister :: StixTree -> UniqSM Register
209 getRegister (StReg (StixMagicId stgreg))
210 = case (magicIdRegMaybe stgreg) of
211 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
214 getRegister (StReg (StixTemp u pk))
215 = returnUs (Fixed pk (UnmappedReg u pk) id)
217 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
219 getRegister (StCall fn kind args)
220 = genCCall fn kind args `thenUs` \ call ->
221 returnUs (Fixed kind reg call)
223 reg = if isFloatingRep kind
224 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
225 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
227 getRegister (StString s)
228 = getUniqLabelNCG `thenUs` \ lbl ->
230 imm_lbl = ImmCLbl lbl
232 code dst = mkSeqInstrs [
235 ASCII True (_UNPK_ s),
237 #if alpha_TARGET_ARCH
238 LDA dst (AddrImm imm_lbl)
241 MOV L (OpImm imm_lbl) (OpReg dst)
243 #if sparc_TARGET_ARCH
244 SETHI (HI imm_lbl) dst,
245 OR False dst (RIImm (LO imm_lbl)) dst
249 returnUs (Any PtrRep code)
251 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
252 = getUniqLabelNCG `thenUs` \ lbl ->
254 imm_lbl = ImmCLbl lbl
256 code dst = mkSeqInstrs [
259 ASCII False (init xs),
261 #if alpha_TARGET_ARCH
262 LDA dst (AddrImm imm_lbl)
265 MOV L (OpImm imm_lbl) (OpReg dst)
267 #if sparc_TARGET_ARCH
268 SETHI (HI imm_lbl) dst,
269 OR False dst (RIImm (LO imm_lbl)) dst
273 returnUs (Any PtrRep code)
275 xs = _UNPK_ (_TAIL_ s)
277 -- end of machine-"independent" bit; here we go on the rest...
279 #if alpha_TARGET_ARCH
281 getRegister (StDouble d)
282 = getUniqLabelNCG `thenUs` \ lbl ->
283 getNewRegNCG PtrRep `thenUs` \ tmp ->
284 let code dst = mkSeqInstrs [
287 DATA TF [ImmLab (rational d)],
289 LDA tmp (AddrImm (ImmCLbl lbl)),
290 LD TF dst (AddrReg tmp)]
292 returnUs (Any DoubleRep code)
294 getRegister (StPrim primop [x]) -- unary PrimOps
296 IntNegOp -> trivialUCode (NEG Q False) x
297 IntAbsOp -> trivialUCode (ABS Q) x
299 NotOp -> trivialUCode NOT x
301 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
302 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
304 OrdOp -> coerceIntCode IntRep x
307 Float2IntOp -> coerceFP2Int x
308 Int2FloatOp -> coerceInt2FP pr x
309 Double2IntOp -> coerceFP2Int x
310 Int2DoubleOp -> coerceInt2FP pr x
312 Double2FloatOp -> coerceFltCode x
313 Float2DoubleOp -> coerceFltCode x
315 other_op -> getRegister (StCall fn DoubleRep [x])
317 fn = case other_op of
318 FloatExpOp -> SLIT("exp")
319 FloatLogOp -> SLIT("log")
320 FloatSqrtOp -> SLIT("sqrt")
321 FloatSinOp -> SLIT("sin")
322 FloatCosOp -> SLIT("cos")
323 FloatTanOp -> SLIT("tan")
324 FloatAsinOp -> SLIT("asin")
325 FloatAcosOp -> SLIT("acos")
326 FloatAtanOp -> SLIT("atan")
327 FloatSinhOp -> SLIT("sinh")
328 FloatCoshOp -> SLIT("cosh")
329 FloatTanhOp -> SLIT("tanh")
330 DoubleExpOp -> SLIT("exp")
331 DoubleLogOp -> SLIT("log")
332 DoubleSqrtOp -> SLIT("sqrt")
333 DoubleSinOp -> SLIT("sin")
334 DoubleCosOp -> SLIT("cos")
335 DoubleTanOp -> SLIT("tan")
336 DoubleAsinOp -> SLIT("asin")
337 DoubleAcosOp -> SLIT("acos")
338 DoubleAtanOp -> SLIT("atan")
339 DoubleSinhOp -> SLIT("sinh")
340 DoubleCoshOp -> SLIT("cosh")
341 DoubleTanhOp -> SLIT("tanh")
343 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
345 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
347 CharGtOp -> trivialCode (CMP LTT) y x
348 CharGeOp -> trivialCode (CMP LE) y x
349 CharEqOp -> trivialCode (CMP EQQ) x y
350 CharNeOp -> int_NE_code x y
351 CharLtOp -> trivialCode (CMP LTT) x y
352 CharLeOp -> trivialCode (CMP LE) x y
354 IntGtOp -> trivialCode (CMP LTT) y x
355 IntGeOp -> trivialCode (CMP LE) y x
356 IntEqOp -> trivialCode (CMP EQQ) x y
357 IntNeOp -> int_NE_code x y
358 IntLtOp -> trivialCode (CMP LTT) x y
359 IntLeOp -> trivialCode (CMP LE) x y
361 WordGtOp -> trivialCode (CMP ULT) y x
362 WordGeOp -> trivialCode (CMP ULE) x y
363 WordEqOp -> trivialCode (CMP EQQ) x y
364 WordNeOp -> int_NE_code x y
365 WordLtOp -> trivialCode (CMP ULT) x y
366 WordLeOp -> trivialCode (CMP ULE) x y
368 AddrGtOp -> trivialCode (CMP ULT) y x
369 AddrGeOp -> trivialCode (CMP ULE) y x
370 AddrEqOp -> trivialCode (CMP EQQ) x y
371 AddrNeOp -> int_NE_code x y
372 AddrLtOp -> trivialCode (CMP ULT) x y
373 AddrLeOp -> trivialCode (CMP ULE) x y
375 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
376 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
377 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
378 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
379 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
380 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
382 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
383 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
384 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
385 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
386 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
387 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
389 IntAddOp -> trivialCode (ADD Q False) x y
390 IntSubOp -> trivialCode (SUB Q False) x y
391 IntMulOp -> trivialCode (MUL Q False) x y
392 IntQuotOp -> trivialCode (DIV Q False) x y
393 IntRemOp -> trivialCode (REM Q False) x y
395 WordQuotOp -> trivialCode (DIV Q True) x y
396 WordRemOp -> trivialCode (REM Q True) 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 XorOp -> trivialCode XOR x y
411 SllOp -> trivialCode SLL x y
412 SraOp -> trivialCode SRA x y
413 SrlOp -> trivialCode SRL x y
415 ISllOp -> panic "AlphaGen:isll"
416 ISraOp -> panic "AlphaGen:isra"
417 ISrlOp -> panic "AlphaGen:isrl"
419 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
420 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
422 {- ------------------------------------------------------------
423 Some bizarre special code for getting condition codes into
424 registers. Integer non-equality is a test for equality
425 followed by an XOR with 1. (Integer comparisons always set
426 the result register to 0 or 1.) Floating point comparisons of
427 any kind leave the result in a floating point register, so we
428 need to wrangle an integer register out of things.
430 int_NE_code :: StixTree -> StixTree -> UniqSM Register
433 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
434 getNewRegNCG IntRep `thenUs` \ tmp ->
436 code = registerCode register tmp
437 src = registerName register tmp
438 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
440 returnUs (Any IntRep code__2)
442 {- ------------------------------------------------------------
443 Comments for int_NE_code also apply to cmpF_code
446 :: (Reg -> Reg -> Reg -> Instr)
448 -> StixTree -> StixTree
451 cmpF_code instr cond x y
452 = trivialFCode pr instr x y `thenUs` \ register ->
453 getNewRegNCG DoubleRep `thenUs` \ tmp ->
454 getUniqLabelNCG `thenUs` \ lbl ->
456 code = registerCode register tmp
457 result = registerName register tmp
459 code__2 dst = code . mkSeqInstrs [
460 OR zeroh (RIImm (ImmInt 1)) dst,
461 BF cond result (ImmCLbl lbl),
462 OR zeroh (RIReg zeroh) dst,
465 returnUs (Any IntRep code__2)
467 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
468 ------------------------------------------------------------
470 getRegister (StInd pk mem)
471 = getAmode mem `thenUs` \ amode ->
473 code = amodeCode amode
474 src = amodeAddr amode
475 size = primRepToSize pk
476 code__2 dst = code . mkSeqInstr (LD size dst src)
478 returnUs (Any pk code__2)
480 getRegister (StInt i)
483 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
485 returnUs (Any IntRep code)
488 code dst = mkSeqInstr (LDI Q dst src)
490 returnUs (Any IntRep code)
492 src = ImmInt (fromInteger i)
497 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
499 returnUs (Any PtrRep code)
502 imm__2 = case imm of Just x -> x
504 #endif {- alpha_TARGET_ARCH -}
505 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
508 getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
510 getRegister (StDouble 0.0)
512 code dst = mkSeqInstrs [FLDZ]
514 returnUs (Any DoubleRep code)
516 getRegister (StDouble 1.0)
518 code dst = mkSeqInstrs [FLD1]
520 returnUs (Any DoubleRep code)
522 getRegister (StDouble d)
523 = getUniqLabelNCG `thenUs` \ lbl ->
524 --getNewRegNCG PtrRep `thenUs` \ tmp ->
525 let code dst = mkSeqInstrs [
528 DATA DF [dblImmLit d],
530 FLD DF (OpImm (ImmCLbl lbl))
533 returnUs (Any DoubleRep code)
535 getRegister (StPrim primop [x]) -- unary PrimOps
537 IntNegOp -> trivialUCode (NEGI L) x
538 IntAbsOp -> absIntCode x
540 NotOp -> trivialUCode (NOT L) x
542 FloatNegOp -> trivialUFCode FloatRep FCHS x
543 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
544 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
546 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
548 OrdOp -> coerceIntCode IntRep x
551 Float2IntOp -> coerceFP2Int x
552 Int2FloatOp -> coerceInt2FP FloatRep x
553 Double2IntOp -> coerceFP2Int x
554 Int2DoubleOp -> coerceInt2FP DoubleRep x
556 Double2FloatOp -> coerceFltCode x
557 Float2DoubleOp -> coerceFltCode x
561 fixed_x = if is_float_op -- promote to double
562 then StPrim Float2DoubleOp [x]
565 getRegister (StCall fn DoubleRep [x])
569 FloatExpOp -> (True, SLIT("exp"))
570 FloatLogOp -> (True, SLIT("log"))
572 FloatSinOp -> (True, SLIT("sin"))
573 FloatCosOp -> (True, SLIT("cos"))
574 FloatTanOp -> (True, SLIT("tan"))
576 FloatAsinOp -> (True, SLIT("asin"))
577 FloatAcosOp -> (True, SLIT("acos"))
578 FloatAtanOp -> (True, SLIT("atan"))
580 FloatSinhOp -> (True, SLIT("sinh"))
581 FloatCoshOp -> (True, SLIT("cosh"))
582 FloatTanhOp -> (True, SLIT("tanh"))
584 DoubleExpOp -> (False, SLIT("exp"))
585 DoubleLogOp -> (False, SLIT("log"))
587 DoubleSinOp -> (False, SLIT("sin"))
588 DoubleCosOp -> (False, SLIT("cos"))
589 DoubleTanOp -> (False, SLIT("tan"))
591 DoubleAsinOp -> (False, SLIT("asin"))
592 DoubleAcosOp -> (False, SLIT("acos"))
593 DoubleAtanOp -> (False, SLIT("atan"))
595 DoubleSinhOp -> (False, SLIT("sinh"))
596 DoubleCoshOp -> (False, SLIT("cosh"))
597 DoubleTanhOp -> (False, SLIT("tanh"))
599 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
601 CharGtOp -> condIntReg GTT x y
602 CharGeOp -> condIntReg GE x y
603 CharEqOp -> condIntReg EQQ x y
604 CharNeOp -> condIntReg NE x y
605 CharLtOp -> condIntReg LTT x y
606 CharLeOp -> condIntReg LE x y
608 IntGtOp -> condIntReg GTT x y
609 IntGeOp -> condIntReg GE x y
610 IntEqOp -> condIntReg EQQ x y
611 IntNeOp -> condIntReg NE x y
612 IntLtOp -> condIntReg LTT x y
613 IntLeOp -> condIntReg LE x y
615 WordGtOp -> condIntReg GU x y
616 WordGeOp -> condIntReg GEU x y
617 WordEqOp -> condIntReg EQQ x y
618 WordNeOp -> condIntReg NE x y
619 WordLtOp -> condIntReg LU x y
620 WordLeOp -> condIntReg LEU x y
622 AddrGtOp -> condIntReg GU x y
623 AddrGeOp -> condIntReg GEU x y
624 AddrEqOp -> condIntReg EQQ x y
625 AddrNeOp -> condIntReg NE x y
626 AddrLtOp -> condIntReg LU x y
627 AddrLeOp -> condIntReg LEU x y
629 FloatGtOp -> condFltReg GTT x y
630 FloatGeOp -> condFltReg GE x y
631 FloatEqOp -> condFltReg EQQ x y
632 FloatNeOp -> condFltReg NE x y
633 FloatLtOp -> condFltReg LTT x y
634 FloatLeOp -> condFltReg LE x y
636 DoubleGtOp -> condFltReg GTT x y
637 DoubleGeOp -> condFltReg GE x y
638 DoubleEqOp -> condFltReg EQQ x y
639 DoubleNeOp -> condFltReg NE x y
640 DoubleLtOp -> condFltReg LTT x y
641 DoubleLeOp -> condFltReg LE x y
643 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
644 -- this should be optimised by the generic Opts,
645 -- I don't know why it is not (sometimes)!
647 [x, StInt 0] -> getRegister x
652 IntSubOp -> sub_code L x y
653 IntQuotOp -> quot_code L x y True{-division-}
654 IntRemOp -> quot_code L x y False{-remainder-}
655 IntMulOp -> trivialCode (IMUL L) x y {-True-}
657 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
658 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
659 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
660 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
662 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
663 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
664 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
665 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
667 AndOp -> trivialCode (AND L) x y {-True-}
668 OrOp -> trivialCode (OR L) x y {-True-}
669 XorOp -> trivialCode (XOR L) x y {-True-}
671 {- Shift ops on x86s have constraints on their source, it
672 either has to be Imm, CL or 1
673 => trivialCode's is not restrictive enough (sigh.)
676 SllOp -> shift_code (SHL L) x y {-False-}
677 SraOp -> shift_code (SAR L) x y {-False-}
678 SrlOp -> shift_code (SHR L) x y {-False-}
681 ISllOp -> panic "I386Gen:isll"
682 ISraOp -> panic "I386Gen:isra"
683 ISrlOp -> panic "I386Gen:isrl"
685 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
686 where promote x = StPrim Float2DoubleOp [x]
687 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
689 shift_code :: (Operand -> Operand -> Instr)
693 {- Case1: shift length as immediate -}
694 -- Code is the same as the first eq. for trivialCode -- sigh.
695 shift_code instr x y{-amount-}
697 = getRegister x `thenUs` \ register ->
699 op_imm = OpImm imm__2
702 code = registerCode register dst
703 src = registerName register dst
705 mkSeqInstr (COMMENT SLIT("shift_code")) .
707 if isFixed register && src /= dst
709 mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
710 instr op_imm (OpReg dst)]
712 mkSeqInstr (instr op_imm (OpReg src))
714 returnUs (Any IntRep code__2)
717 imm__2 = case imm of Just x -> x
719 {- Case2: shift length is complex (non-immediate) -}
720 shift_code instr x y{-amount-}
721 = getRegister y `thenUs` \ register1 ->
722 getRegister x `thenUs` \ register2 ->
723 -- getNewRegNCG IntRep `thenUs` \ dst ->
725 -- Note: we force the shift length to be loaded
726 -- into ECX, so that we can use CL when shifting.
727 -- (only register location we are allowed
728 -- to put shift amounts.)
730 -- The shift instruction is fed ECX as src reg,
731 -- but we coerce this into CL when printing out.
732 src1 = registerName register1 ecx
733 code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
734 registerCode register1 ecx .
735 mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
737 registerCode register1 ecx
740 code2 = registerCode register2 eax
741 src2 = registerName register2 eax
744 mkSeqInstr (instr (OpReg ecx) (OpReg eax))
746 returnUs (Fixed IntRep eax code__2)
748 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
750 add_code sz x (StInt y)
751 = getRegister x `thenUs` \ register ->
752 getNewRegNCG IntRep `thenUs` \ tmp ->
754 code = registerCode register tmp
755 src1 = registerName register tmp
756 src2 = ImmInt (fromInteger y)
758 mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst))
760 returnUs (Any IntRep code__2)
762 add_code sz x (StInd _ mem)
763 = getRegister x `thenUs` \ register1 ->
764 --getNewRegNCG (registerRep register1)
765 -- `thenUs` \ tmp1 ->
766 getAmode mem `thenUs` \ amode ->
768 code2 = amodeCode amode
769 src2 = amodeAddr amode
771 -- fixedname = registerName register1 eax
772 code__2 dst = let code1 = registerCode register1 dst
773 src1 = registerName register1 dst
774 in asmParThen [code2 asmVoid,code1 asmVoid] .
775 if isFixed register1 && src1 /= dst
776 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
777 ADD sz (OpAddr src2) (OpReg dst)]
779 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
781 returnUs (Any IntRep code__2)
783 add_code sz (StInd _ mem) y
784 = getRegister y `thenUs` \ register2 ->
785 --getNewRegNCG (registerRep register2)
786 -- `thenUs` \ tmp2 ->
787 getAmode mem `thenUs` \ amode ->
789 code1 = amodeCode amode
790 src1 = amodeAddr amode
792 -- fixedname = registerName register2 eax
793 code__2 dst = let code2 = registerCode register2 dst
794 src2 = registerName register2 dst
795 in asmParThen [code1 asmVoid,code2 asmVoid] .
796 if isFixed register2 && src2 /= dst
797 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
798 ADD sz (OpAddr src1) (OpReg dst)]
800 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
802 returnUs (Any IntRep code__2)
805 = getRegister x `thenUs` \ register1 ->
806 getRegister y `thenUs` \ register2 ->
807 getNewRegNCG IntRep `thenUs` \ tmp1 ->
808 getNewRegNCG IntRep `thenUs` \ tmp2 ->
810 code1 = registerCode register1 tmp1 asmVoid
811 src1 = registerName register1 tmp1
812 code2 = registerCode register2 tmp2 asmVoid
813 src2 = registerName register2 tmp2
814 code__2 dst = asmParThen [code1, code2] .
815 mkSeqInstr (LEA sz (OpAddr (Address (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
817 returnUs (Any IntRep code__2)
820 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
822 sub_code sz x (StInt y)
823 = getRegister x `thenUs` \ register ->
824 getNewRegNCG IntRep `thenUs` \ tmp ->
826 code = registerCode register tmp
827 src1 = registerName register tmp
828 src2 = ImmInt (-(fromInteger y))
830 mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst))
832 returnUs (Any IntRep code__2)
834 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
839 -> StixTree -> StixTree
840 -> Bool -- True => division, False => remainder operation
843 -- x must go into eax, edx must be a sign-extension of eax, and y
844 -- should go in some other register (or memory), so that we get
845 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
846 -- put y in memory (if it is not there already)
848 quot_code sz x (StInd pk mem) is_division
849 = getRegister x `thenUs` \ register1 ->
850 getNewRegNCG IntRep `thenUs` \ tmp1 ->
851 getAmode mem `thenUs` \ amode ->
853 code1 = registerCode register1 tmp1 asmVoid
854 src1 = registerName register1 tmp1
855 code2 = amodeCode amode asmVoid
856 src2 = amodeAddr amode
857 code__2 = asmParThen [code1, code2] .
858 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
860 IDIV sz (OpAddr src2)]
862 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
864 quot_code sz x (StInt i) is_division
865 = getRegister x `thenUs` \ register1 ->
866 getNewRegNCG IntRep `thenUs` \ tmp1 ->
868 code1 = registerCode register1 tmp1 asmVoid
869 src1 = registerName register1 tmp1
870 src2 = ImmInt (fromInteger i)
871 code__2 = asmParThen [code1] .
872 mkSeqInstrs [-- we put src2 in (ebx)
873 MOV L (OpImm src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
874 MOV L (OpReg src1) (OpReg eax),
876 IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
878 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
880 quot_code sz x y is_division
881 = getRegister x `thenUs` \ register1 ->
882 getNewRegNCG IntRep `thenUs` \ tmp1 ->
883 getRegister y `thenUs` \ register2 ->
884 getNewRegNCG IntRep `thenUs` \ tmp2 ->
886 code1 = registerCode register1 tmp1 asmVoid
887 src1 = registerName register1 tmp1
888 code2 = registerCode register2 tmp2 asmVoid
889 src2 = registerName register2 tmp2
890 code__2 = asmParThen [code1, code2] .
891 if src2 == ecx || src2 == esi
892 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
894 IDIV sz (OpReg src2)]
895 else mkSeqInstrs [ -- we put src2 in (ebx)
896 MOV L (OpReg src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
897 MOV L (OpReg src1) (OpReg eax),
899 IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
901 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
902 -----------------------
904 getRegister (StInd pk mem)
905 = getAmode mem `thenUs` \ amode ->
907 code = amodeCode amode
908 src = amodeAddr amode
909 size = primRepToSize pk
911 if pk == DoubleRep || pk == FloatRep
912 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
913 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
915 returnUs (Any pk code__2)
918 getRegister (StInt i)
920 src = ImmInt (fromInteger i)
921 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
923 returnUs (Any IntRep code)
928 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
930 returnUs (Any PtrRep code)
933 imm__2 = case imm of Just x -> x
935 #endif {- i386_TARGET_ARCH -}
936 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
937 #if sparc_TARGET_ARCH
939 getRegister (StDouble d)
940 = getUniqLabelNCG `thenUs` \ lbl ->
941 getNewRegNCG PtrRep `thenUs` \ tmp ->
942 let code dst = mkSeqInstrs [
945 DATA DF [dblImmLit d],
947 SETHI (HI (ImmCLbl lbl)) tmp,
948 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
950 returnUs (Any DoubleRep code)
952 getRegister (StPrim primop [x]) -- unary PrimOps
954 IntNegOp -> trivialUCode (SUB False False g0) x
955 IntAbsOp -> absIntCode x
956 NotOp -> trivialUCode (XNOR False g0) x
958 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
960 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
962 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
963 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
965 OrdOp -> coerceIntCode IntRep x
968 Float2IntOp -> coerceFP2Int x
969 Int2FloatOp -> coerceInt2FP FloatRep x
970 Double2IntOp -> coerceFP2Int x
971 Int2DoubleOp -> coerceInt2FP DoubleRep x
975 fixed_x = if is_float_op -- promote to double
976 then StPrim Float2DoubleOp [x]
979 getRegister (StCall fn DoubleRep [x])
983 FloatExpOp -> (True, SLIT("exp"))
984 FloatLogOp -> (True, SLIT("log"))
985 FloatSqrtOp -> (True, SLIT("sqrt"))
987 FloatSinOp -> (True, SLIT("sin"))
988 FloatCosOp -> (True, SLIT("cos"))
989 FloatTanOp -> (True, SLIT("tan"))
991 FloatAsinOp -> (True, SLIT("asin"))
992 FloatAcosOp -> (True, SLIT("acos"))
993 FloatAtanOp -> (True, SLIT("atan"))
995 FloatSinhOp -> (True, SLIT("sinh"))
996 FloatCoshOp -> (True, SLIT("cosh"))
997 FloatTanhOp -> (True, SLIT("tanh"))
999 DoubleExpOp -> (False, SLIT("exp"))
1000 DoubleLogOp -> (False, SLIT("log"))
1001 DoubleSqrtOp -> (True, SLIT("sqrt"))
1003 DoubleSinOp -> (False, SLIT("sin"))
1004 DoubleCosOp -> (False, SLIT("cos"))
1005 DoubleTanOp -> (False, SLIT("tan"))
1007 DoubleAsinOp -> (False, SLIT("asin"))
1008 DoubleAcosOp -> (False, SLIT("acos"))
1009 DoubleAtanOp -> (False, SLIT("atan"))
1011 DoubleSinhOp -> (False, SLIT("sinh"))
1012 DoubleCoshOp -> (False, SLIT("cosh"))
1013 DoubleTanhOp -> (False, SLIT("tanh"))
1014 _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
1016 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1018 CharGtOp -> condIntReg GTT x y
1019 CharGeOp -> condIntReg GE x y
1020 CharEqOp -> condIntReg EQQ x y
1021 CharNeOp -> condIntReg NE x y
1022 CharLtOp -> condIntReg LTT x y
1023 CharLeOp -> condIntReg LE x y
1025 IntGtOp -> condIntReg GTT x y
1026 IntGeOp -> condIntReg GE x y
1027 IntEqOp -> condIntReg EQQ x y
1028 IntNeOp -> condIntReg NE x y
1029 IntLtOp -> condIntReg LTT x y
1030 IntLeOp -> condIntReg LE x y
1032 WordGtOp -> condIntReg GU x y
1033 WordGeOp -> condIntReg GEU x y
1034 WordEqOp -> condIntReg EQQ x y
1035 WordNeOp -> condIntReg NE x y
1036 WordLtOp -> condIntReg LU x y
1037 WordLeOp -> condIntReg LEU x y
1039 AddrGtOp -> condIntReg GU x y
1040 AddrGeOp -> condIntReg GEU x y
1041 AddrEqOp -> condIntReg EQQ x y
1042 AddrNeOp -> condIntReg NE x y
1043 AddrLtOp -> condIntReg LU x y
1044 AddrLeOp -> condIntReg LEU x y
1046 FloatGtOp -> condFltReg GTT x y
1047 FloatGeOp -> condFltReg GE x y
1048 FloatEqOp -> condFltReg EQQ x y
1049 FloatNeOp -> condFltReg NE x y
1050 FloatLtOp -> condFltReg LTT x y
1051 FloatLeOp -> condFltReg LE x y
1053 DoubleGtOp -> condFltReg GTT x y
1054 DoubleGeOp -> condFltReg GE x y
1055 DoubleEqOp -> condFltReg EQQ x y
1056 DoubleNeOp -> condFltReg NE x y
1057 DoubleLtOp -> condFltReg LTT x y
1058 DoubleLeOp -> condFltReg LE x y
1060 IntAddOp -> trivialCode (ADD False False) x y
1061 IntSubOp -> trivialCode (SUB False False) x y
1063 -- ToDo: teach about V8+ SPARC mul/div instructions
1064 IntMulOp -> imul_div SLIT(".umul") x y
1065 IntQuotOp -> imul_div SLIT(".div") x y
1066 IntRemOp -> imul_div SLIT(".rem") x y
1068 FloatAddOp -> trivialFCode FloatRep FADD x y
1069 FloatSubOp -> trivialFCode FloatRep FSUB x y
1070 FloatMulOp -> trivialFCode FloatRep FMUL x y
1071 FloatDivOp -> trivialFCode FloatRep FDIV x y
1073 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1074 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1075 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1076 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1078 AndOp -> trivialCode (AND False) x y
1079 OrOp -> trivialCode (OR False) x y
1080 XorOp -> trivialCode (XOR False) x y
1081 SllOp -> trivialCode SLL x y
1082 SraOp -> trivialCode SRA x y
1083 SrlOp -> trivialCode SRL x y
1085 ISllOp -> panic "SparcGen:isll"
1086 ISraOp -> panic "SparcGen:isra"
1087 ISrlOp -> panic "SparcGen:isrl"
1089 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1090 where promote x = StPrim Float2DoubleOp [x]
1091 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1093 imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1095 getRegister (StInd pk mem)
1096 = getAmode mem `thenUs` \ amode ->
1098 code = amodeCode amode
1099 src = amodeAddr amode
1100 size = primRepToSize pk
1101 code__2 dst = code . mkSeqInstr (LD size src dst)
1103 returnUs (Any pk code__2)
1105 getRegister (StInt i)
1108 src = ImmInt (fromInteger i)
1109 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1111 returnUs (Any IntRep code)
1116 code dst = mkSeqInstrs [
1117 SETHI (HI imm__2) dst,
1118 OR False dst (RIImm (LO imm__2)) dst]
1120 returnUs (Any PtrRep code)
1123 imm__2 = case imm of Just x -> x
1125 #endif {- sparc_TARGET_ARCH -}
1128 %************************************************************************
1130 \subsection{The @Amode@ type}
1132 %************************************************************************
1134 @Amode@s: Memory addressing modes passed up the tree.
1136 data Amode = Amode Address InstrBlock
1138 amodeAddr (Amode addr _) = addr
1139 amodeCode (Amode _ code) = code
1142 Now, given a tree (the argument to an StInd) that references memory,
1143 produce a suitable addressing mode.
1146 getAmode :: StixTree -> UniqSM Amode
1148 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1150 #if alpha_TARGET_ARCH
1152 getAmode (StPrim IntSubOp [x, StInt i])
1153 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1154 getRegister x `thenUs` \ register ->
1156 code = registerCode register tmp
1157 reg = registerName register tmp
1158 off = ImmInt (-(fromInteger i))
1160 returnUs (Amode (AddrRegImm reg off) code)
1162 getAmode (StPrim IntAddOp [x, StInt i])
1163 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1164 getRegister x `thenUs` \ register ->
1166 code = registerCode register tmp
1167 reg = registerName register tmp
1168 off = ImmInt (fromInteger i)
1170 returnUs (Amode (AddrRegImm reg off) code)
1174 = returnUs (Amode (AddrImm imm__2) id)
1177 imm__2 = case imm of Just x -> x
1180 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1181 getRegister other `thenUs` \ register ->
1183 code = registerCode register tmp
1184 reg = registerName register tmp
1186 returnUs (Amode (AddrReg reg) code)
1188 #endif {- alpha_TARGET_ARCH -}
1189 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1190 #if i386_TARGET_ARCH
1192 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 (Address (Just reg) Nothing off) code)
1202 getAmode (StPrim IntAddOp [x, StInt i])
1205 code = mkSeqInstrs []
1207 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1210 imm__2 = case imm of Just x -> x
1212 getAmode (StPrim IntAddOp [x, StInt i])
1213 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1214 getRegister x `thenUs` \ register ->
1216 code = registerCode register tmp
1217 reg = registerName register tmp
1218 off = ImmInt (fromInteger i)
1220 returnUs (Amode (Address (Just reg) Nothing off) code)
1222 getAmode (StPrim IntAddOp [x, y])
1223 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1224 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1225 getRegister x `thenUs` \ register1 ->
1226 getRegister y `thenUs` \ register2 ->
1228 code1 = registerCode register1 tmp1 asmVoid
1229 reg1 = registerName register1 tmp1
1230 code2 = registerCode register2 tmp2 asmVoid
1231 reg2 = registerName register2 tmp2
1232 code__2 = asmParThen [code1, code2]
1234 returnUs (Amode (Address (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1239 code = mkSeqInstrs []
1241 returnUs (Amode (ImmAddr imm__2 0) code)
1244 imm__2 = case imm of Just x -> x
1247 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1248 getRegister other `thenUs` \ register ->
1250 code = registerCode register tmp
1251 reg = registerName register tmp
1254 returnUs (Amode (Address (Just reg) Nothing (ImmInt 0)) code)
1256 #endif {- i386_TARGET_ARCH -}
1257 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1258 #if sparc_TARGET_ARCH
1260 getAmode (StPrim IntSubOp [x, StInt i])
1262 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1263 getRegister x `thenUs` \ register ->
1265 code = registerCode register tmp
1266 reg = registerName register tmp
1267 off = ImmInt (-(fromInteger i))
1269 returnUs (Amode (AddrRegImm reg off) code)
1272 getAmode (StPrim IntAddOp [x, StInt i])
1274 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1275 getRegister x `thenUs` \ register ->
1277 code = registerCode register tmp
1278 reg = registerName register tmp
1279 off = ImmInt (fromInteger i)
1281 returnUs (Amode (AddrRegImm reg off) code)
1283 getAmode (StPrim IntAddOp [x, y])
1284 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1285 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1286 getRegister x `thenUs` \ register1 ->
1287 getRegister y `thenUs` \ register2 ->
1289 code1 = registerCode register1 tmp1 asmVoid
1290 reg1 = registerName register1 tmp1
1291 code2 = registerCode register2 tmp2 asmVoid
1292 reg2 = registerName register2 tmp2
1293 code__2 = asmParThen [code1, code2]
1295 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1299 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1301 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1303 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1306 imm__2 = case imm of Just x -> x
1309 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1310 getRegister other `thenUs` \ register ->
1312 code = registerCode register tmp
1313 reg = registerName register tmp
1316 returnUs (Amode (AddrRegImm reg off) code)
1318 #endif {- sparc_TARGET_ARCH -}
1321 %************************************************************************
1323 \subsection{The @CondCode@ type}
1325 %************************************************************************
1327 Condition codes passed up the tree.
1329 data CondCode = CondCode Bool Cond InstrBlock
1331 condName (CondCode _ cond _) = cond
1332 condFloat (CondCode is_float _ _) = is_float
1333 condCode (CondCode _ _ code) = code
1336 Set up a condition code for a conditional branch.
1339 getCondCode :: StixTree -> UniqSM CondCode
1341 #if alpha_TARGET_ARCH
1342 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1343 #endif {- alpha_TARGET_ARCH -}
1344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1346 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1347 -- yes, they really do seem to want exactly the same!
1349 getCondCode (StPrim primop [x, y])
1351 CharGtOp -> condIntCode GTT x y
1352 CharGeOp -> condIntCode GE x y
1353 CharEqOp -> condIntCode EQQ x y
1354 CharNeOp -> condIntCode NE x y
1355 CharLtOp -> condIntCode LTT x y
1356 CharLeOp -> condIntCode LE x y
1358 IntGtOp -> condIntCode GTT x y
1359 IntGeOp -> condIntCode GE x y
1360 IntEqOp -> condIntCode EQQ x y
1361 IntNeOp -> condIntCode NE x y
1362 IntLtOp -> condIntCode LTT x y
1363 IntLeOp -> condIntCode LE x y
1365 WordGtOp -> condIntCode GU x y
1366 WordGeOp -> condIntCode GEU x y
1367 WordEqOp -> condIntCode EQQ x y
1368 WordNeOp -> condIntCode NE x y
1369 WordLtOp -> condIntCode LU x y
1370 WordLeOp -> condIntCode LEU x y
1372 AddrGtOp -> condIntCode GU x y
1373 AddrGeOp -> condIntCode GEU x y
1374 AddrEqOp -> condIntCode EQQ x y
1375 AddrNeOp -> condIntCode NE x y
1376 AddrLtOp -> condIntCode LU x y
1377 AddrLeOp -> condIntCode LEU x y
1379 FloatGtOp -> condFltCode GTT x y
1380 FloatGeOp -> condFltCode GE x y
1381 FloatEqOp -> condFltCode EQQ x y
1382 FloatNeOp -> condFltCode NE x y
1383 FloatLtOp -> condFltCode LTT x y
1384 FloatLeOp -> condFltCode LE x y
1386 DoubleGtOp -> condFltCode GTT x y
1387 DoubleGeOp -> condFltCode GE x y
1388 DoubleEqOp -> condFltCode EQQ x y
1389 DoubleNeOp -> condFltCode NE x y
1390 DoubleLtOp -> condFltCode LTT x y
1391 DoubleLeOp -> condFltCode LE x y
1393 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1398 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1399 passed back up the tree.
1402 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1404 #if alpha_TARGET_ARCH
1405 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1406 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1407 #endif {- alpha_TARGET_ARCH -}
1409 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1410 #if i386_TARGET_ARCH
1412 condIntCode cond (StInd _ x) y
1414 = getAmode x `thenUs` \ amode ->
1416 code1 = amodeCode amode asmVoid
1417 y__2 = amodeAddr amode
1418 code__2 = asmParThen [code1] .
1419 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1421 returnUs (CondCode False cond code__2)
1424 imm__2 = case imm of Just x -> x
1426 condIntCode cond x (StInt 0)
1427 = getRegister x `thenUs` \ register1 ->
1428 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1430 code1 = registerCode register1 tmp1 asmVoid
1431 src1 = registerName register1 tmp1
1432 code__2 = asmParThen [code1] .
1433 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1435 returnUs (CondCode False cond code__2)
1437 condIntCode cond x y
1439 = getRegister x `thenUs` \ register1 ->
1440 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1442 code1 = registerCode register1 tmp1 asmVoid
1443 src1 = registerName register1 tmp1
1444 code__2 = asmParThen [code1] .
1445 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1447 returnUs (CondCode False cond code__2)
1450 imm__2 = case imm of Just x -> x
1452 condIntCode cond (StInd _ x) y
1453 = getAmode x `thenUs` \ amode ->
1454 getRegister y `thenUs` \ register2 ->
1455 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1457 code1 = amodeCode amode asmVoid
1458 src1 = amodeAddr amode
1459 code2 = registerCode register2 tmp2 asmVoid
1460 src2 = registerName register2 tmp2
1461 code__2 = asmParThen [code1, code2] .
1462 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1464 returnUs (CondCode False cond code__2)
1466 condIntCode cond y (StInd _ x)
1467 = getAmode x `thenUs` \ amode ->
1468 getRegister y `thenUs` \ register2 ->
1469 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1471 code1 = amodeCode amode asmVoid
1472 src1 = amodeAddr amode
1473 code2 = registerCode register2 tmp2 asmVoid
1474 src2 = registerName register2 tmp2
1475 code__2 = asmParThen [code1, code2] .
1476 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1478 returnUs (CondCode False cond code__2)
1480 condIntCode cond x y
1481 = getRegister x `thenUs` \ register1 ->
1482 getRegister y `thenUs` \ register2 ->
1483 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1484 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1486 code1 = registerCode register1 tmp1 asmVoid
1487 src1 = registerName register1 tmp1
1488 code2 = registerCode register2 tmp2 asmVoid
1489 src2 = registerName register2 tmp2
1490 code__2 = asmParThen [code1, code2] .
1491 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1493 returnUs (CondCode False cond code__2)
1497 condFltCode cond x (StDouble 0.0)
1498 = getRegister x `thenUs` \ register1 ->
1499 getNewRegNCG (registerRep register1)
1502 pk1 = registerRep register1
1503 code1 = registerCode register1 tmp1
1504 src1 = registerName register1 tmp1
1506 code__2 = asmParThen [code1 asmVoid] .
1507 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1509 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1510 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1514 returnUs (CondCode True (fix_FP_cond 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)
1524 pk1 = registerRep register1
1525 code1 = registerCode register1 tmp1
1526 src1 = registerName register1 tmp1
1528 code2 = registerCode register2 tmp2
1529 src2 = registerName register2 tmp2
1531 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1532 mkSeqInstrs [FUCOMPP,
1534 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1535 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1539 returnUs (CondCode True (fix_FP_cond cond) code__2)
1541 {- On the 486, the flags set by FP compare are the unsigned ones!
1542 (This looks like a HACK to me. WDP 96/03)
1545 fix_FP_cond :: Cond -> Cond
1547 fix_FP_cond GE = GEU
1548 fix_FP_cond GTT = GU
1549 fix_FP_cond LTT = LU
1550 fix_FP_cond LE = LEU
1551 fix_FP_cond any = any
1553 #endif {- i386_TARGET_ARCH -}
1554 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1555 #if sparc_TARGET_ARCH
1557 condIntCode cond x (StInt y)
1559 = getRegister x `thenUs` \ register ->
1560 getNewRegNCG IntRep `thenUs` \ tmp ->
1562 code = registerCode register tmp
1563 src1 = registerName register tmp
1564 src2 = ImmInt (fromInteger y)
1565 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1567 returnUs (CondCode False cond code__2)
1569 condIntCode cond x y
1570 = getRegister x `thenUs` \ register1 ->
1571 getRegister y `thenUs` \ register2 ->
1572 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1573 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1575 code1 = registerCode register1 tmp1 asmVoid
1576 src1 = registerName register1 tmp1
1577 code2 = registerCode register2 tmp2 asmVoid
1578 src2 = registerName register2 tmp2
1579 code__2 = asmParThen [code1, code2] .
1580 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1582 returnUs (CondCode False cond code__2)
1585 condFltCode cond x y
1586 = getRegister x `thenUs` \ register1 ->
1587 getRegister y `thenUs` \ register2 ->
1588 getNewRegNCG (registerRep register1)
1590 getNewRegNCG (registerRep register2)
1592 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1594 promote x = asmInstr (FxTOy F DF x tmp)
1596 pk1 = registerRep register1
1597 code1 = registerCode register1 tmp1
1598 src1 = registerName register1 tmp1
1600 pk2 = registerRep register2
1601 code2 = registerCode register2 tmp2
1602 src2 = registerName register2 tmp2
1606 asmParThen [code1 asmVoid, code2 asmVoid] .
1607 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1608 else if pk1 == FloatRep then
1609 asmParThen [code1 (promote src1), code2 asmVoid] .
1610 mkSeqInstr (FCMP True DF tmp src2)
1612 asmParThen [code1 asmVoid, code2 (promote src2)] .
1613 mkSeqInstr (FCMP True DF src1 tmp)
1615 returnUs (CondCode True cond code__2)
1617 #endif {- sparc_TARGET_ARCH -}
1620 %************************************************************************
1622 \subsection{Generating assignments}
1624 %************************************************************************
1626 Assignments are really at the heart of the whole code generation
1627 business. Almost all top-level nodes of any real importance are
1628 assignments, which correspond to loads, stores, or register transfers.
1629 If we're really lucky, some of the register transfers will go away,
1630 because we can use the destination register to complete the code
1631 generation for the right hand side. This only fails when the right
1632 hand side is forced into a fixed register (e.g. the result of a call).
1635 assignIntCode, assignFltCode
1636 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1638 #if alpha_TARGET_ARCH
1640 assignIntCode pk (StInd _ dst) src
1641 = getNewRegNCG IntRep `thenUs` \ tmp ->
1642 getAmode dst `thenUs` \ amode ->
1643 getRegister src `thenUs` \ register ->
1645 code1 = amodeCode amode asmVoid
1646 dst__2 = amodeAddr amode
1647 code2 = registerCode register tmp asmVoid
1648 src__2 = registerName register tmp
1649 sz = primRepToSize pk
1650 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1654 assignIntCode pk dst src
1655 = getRegister dst `thenUs` \ register1 ->
1656 getRegister src `thenUs` \ register2 ->
1658 dst__2 = registerName register1 zeroh
1659 code = registerCode register2 dst__2
1660 src__2 = registerName register2 dst__2
1661 code__2 = if isFixed register2
1662 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1667 #endif {- alpha_TARGET_ARCH -}
1668 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1669 #if i386_TARGET_ARCH
1671 assignIntCode pk (StInd _ dst) src
1672 = getAmode dst `thenUs` \ amode ->
1673 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1675 code1 = amodeCode amode asmVoid
1676 dst__2 = amodeAddr amode
1677 code__2 = asmParThen [code1, codesrc asmVoid] .
1678 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1684 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1688 = returnUs (asmParThen [], OpImm imm_op, L)
1691 imm_op = case imm of Just x -> x
1694 = getRegister op `thenUs` \ register ->
1695 getNewRegNCG (registerRep register)
1698 code = registerCode register tmp
1699 reg = registerName register tmp
1700 pk = registerRep register
1701 sz = primRepToSize pk
1703 returnUs (code, OpReg reg, sz)
1705 assignIntCode pk dst (StInd _ src)
1706 = getNewRegNCG IntRep `thenUs` \ tmp ->
1707 getAmode src `thenUs` \ amode ->
1708 getRegister dst `thenUs` \ register ->
1710 code1 = amodeCode amode asmVoid
1711 src__2 = amodeAddr amode
1712 code2 = registerCode register tmp asmVoid
1713 dst__2 = registerName register tmp
1714 sz = primRepToSize pk
1715 code__2 = asmParThen [code1, code2] .
1716 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1720 assignIntCode pk dst src
1721 = getRegister dst `thenUs` \ register1 ->
1722 getRegister src `thenUs` \ register2 ->
1723 getNewRegNCG IntRep `thenUs` \ tmp ->
1725 dst__2 = registerName register1 tmp
1726 code = registerCode register2 dst__2
1727 src__2 = registerName register2 dst__2
1728 code__2 = if isFixed register2 && dst__2 /= src__2
1729 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1734 #endif {- i386_TARGET_ARCH -}
1735 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1736 #if sparc_TARGET_ARCH
1738 assignIntCode pk (StInd _ dst) src
1739 = getNewRegNCG IntRep `thenUs` \ tmp ->
1740 getAmode dst `thenUs` \ amode ->
1741 getRegister src `thenUs` \ register ->
1743 code1 = amodeCode amode asmVoid
1744 dst__2 = amodeAddr amode
1745 code2 = registerCode register tmp asmVoid
1746 src__2 = registerName register tmp
1747 sz = primRepToSize pk
1748 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1752 assignIntCode pk dst src
1753 = getRegister dst `thenUs` \ register1 ->
1754 getRegister src `thenUs` \ register2 ->
1756 dst__2 = registerName register1 g0
1757 code = registerCode register2 dst__2
1758 src__2 = registerName register2 dst__2
1759 code__2 = if isFixed register2
1760 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1765 #endif {- sparc_TARGET_ARCH -}
1768 % --------------------------------
1769 Floating-point assignments:
1770 % --------------------------------
1772 #if alpha_TARGET_ARCH
1774 assignFltCode pk (StInd _ dst) src
1775 = getNewRegNCG pk `thenUs` \ tmp ->
1776 getAmode dst `thenUs` \ amode ->
1777 getRegister src `thenUs` \ register ->
1779 code1 = amodeCode amode asmVoid
1780 dst__2 = amodeAddr amode
1781 code2 = registerCode register tmp asmVoid
1782 src__2 = registerName register tmp
1783 sz = primRepToSize pk
1784 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1788 assignFltCode pk dst src
1789 = getRegister dst `thenUs` \ register1 ->
1790 getRegister src `thenUs` \ register2 ->
1792 dst__2 = registerName register1 zeroh
1793 code = registerCode register2 dst__2
1794 src__2 = registerName register2 dst__2
1795 code__2 = if isFixed register2
1796 then code . mkSeqInstr (FMOV src__2 dst__2)
1801 #endif {- alpha_TARGET_ARCH -}
1802 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1803 #if i386_TARGET_ARCH
1805 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1806 = getNewRegNCG IntRep `thenUs` \ tmp ->
1807 getAmode src `thenUs` \ amodesrc ->
1808 getAmode dst `thenUs` \ amodedst ->
1809 --getRegister src `thenUs` \ register ->
1811 codesrc1 = amodeCode amodesrc asmVoid
1812 addrsrc1 = amodeAddr amodesrc
1813 codedst1 = amodeCode amodedst asmVoid
1814 addrdst1 = amodeAddr amodedst
1815 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1816 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1818 code__2 = asmParThen [codesrc1, codedst1] .
1819 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1820 MOV L (OpReg tmp) (OpAddr addrdst1)]
1823 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1824 MOV L (OpReg tmp) (OpAddr addrdst2)]
1829 assignFltCode pk (StInd _ dst) src
1830 = --getNewRegNCG pk `thenUs` \ tmp ->
1831 getAmode dst `thenUs` \ amode ->
1832 getRegister src `thenUs` \ register ->
1834 sz = primRepToSize pk
1835 dst__2 = amodeAddr amode
1837 code1 = amodeCode amode asmVoid
1838 code2 = registerCode register {-tmp-}st0 asmVoid
1840 --src__2= registerName register tmp
1841 pk__2 = registerRep register
1842 sz__2 = primRepToSize pk__2
1844 code__2 = asmParThen [code1, code2] .
1845 mkSeqInstr (FSTP sz (OpAddr dst__2))
1849 assignFltCode pk dst src
1850 = getRegister dst `thenUs` \ register1 ->
1851 getRegister src `thenUs` \ register2 ->
1852 --getNewRegNCG (registerRep register2)
1853 -- `thenUs` \ tmp ->
1855 sz = primRepToSize pk
1856 dst__2 = registerName register1 st0 --tmp
1858 code = registerCode register2 dst__2
1859 src__2 = registerName register2 dst__2
1865 #endif {- i386_TARGET_ARCH -}
1866 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1867 #if sparc_TARGET_ARCH
1869 assignFltCode pk (StInd _ dst) src
1870 = getNewRegNCG pk `thenUs` \ tmp1 ->
1871 getAmode dst `thenUs` \ amode ->
1872 getRegister src `thenUs` \ register ->
1874 sz = primRepToSize pk
1875 dst__2 = amodeAddr amode
1877 code1 = amodeCode amode asmVoid
1878 code2 = registerCode register tmp1 asmVoid
1880 src__2 = registerName register tmp1
1881 pk__2 = registerRep register
1882 sz__2 = primRepToSize pk__2
1884 code__2 = asmParThen [code1, code2] .
1886 mkSeqInstr (ST sz src__2 dst__2)
1888 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1892 assignFltCode pk dst src
1893 = getRegister dst `thenUs` \ register1 ->
1894 getRegister src `thenUs` \ register2 ->
1896 pk__2 = registerRep register2
1897 sz__2 = primRepToSize pk__2
1899 getNewRegNCG pk__2 `thenUs` \ tmp ->
1901 sz = primRepToSize pk
1902 dst__2 = registerName register1 g0 -- must be Fixed
1905 reg__2 = if pk /= pk__2 then tmp else dst__2
1907 code = registerCode register2 reg__2
1909 src__2 = registerName register2 reg__2
1913 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1914 else if isFixed register2 then
1915 code . mkSeqInstr (FMOV sz src__2 dst__2)
1921 #endif {- sparc_TARGET_ARCH -}
1924 %************************************************************************
1926 \subsection{Generating an unconditional branch}
1928 %************************************************************************
1930 We accept two types of targets: an immediate CLabel or a tree that
1931 gets evaluated into a register. Any CLabels which are AsmTemporaries
1932 are assumed to be in the local block of code, close enough for a
1933 branch instruction. Other CLabels are assumed to be far away.
1935 (If applicable) Do not fill the delay slots here; you will confuse the
1939 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1941 #if alpha_TARGET_ARCH
1943 genJump (StCLbl lbl)
1944 | isAsmTemp lbl = returnInstr (BR target)
1945 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1947 target = ImmCLbl lbl
1950 = getRegister tree `thenUs` \ register ->
1951 getNewRegNCG PtrRep `thenUs` \ tmp ->
1953 dst = registerName register pv
1954 code = registerCode register pv
1955 target = registerName register pv
1957 if isFixed register then
1958 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1960 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1962 #endif {- alpha_TARGET_ARCH -}
1963 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1964 #if i386_TARGET_ARCH
1967 genJump (StCLbl lbl)
1968 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1969 | otherwise = returnInstrs [JMP (OpImm target)]
1971 target = ImmCLbl lbl
1974 genJump (StInd pk mem)
1975 = getAmode mem `thenUs` \ amode ->
1977 code = amodeCode amode
1978 target = amodeAddr amode
1980 returnSeq code [JMP (OpAddr target)]
1984 = returnInstr (JMP (OpImm target))
1987 = getRegister tree `thenUs` \ register ->
1988 getNewRegNCG PtrRep `thenUs` \ tmp ->
1990 code = registerCode register tmp
1991 target = registerName register tmp
1993 returnSeq code [JMP (OpReg target)]
1996 target = case imm of Just x -> x
1998 #endif {- i386_TARGET_ARCH -}
1999 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2000 #if sparc_TARGET_ARCH
2002 genJump (StCLbl lbl)
2003 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
2004 | otherwise = returnInstrs [CALL target 0 True, NOP]
2006 target = ImmCLbl lbl
2009 = getRegister tree `thenUs` \ register ->
2010 getNewRegNCG PtrRep `thenUs` \ tmp ->
2012 code = registerCode register tmp
2013 target = registerName register tmp
2015 returnSeq code [JMP (AddrRegReg target g0), NOP]
2017 #endif {- sparc_TARGET_ARCH -}
2020 %************************************************************************
2022 \subsection{Conditional jumps}
2024 %************************************************************************
2026 Conditional jumps are always to local labels, so we can use branch
2027 instructions. We peek at the arguments to decide what kind of
2030 ALPHA: For comparisons with 0, we're laughing, because we can just do
2031 the desired conditional branch.
2033 I386: First, we have to ensure that the condition
2034 codes are set according to the supplied comparison operation.
2036 SPARC: First, we have to ensure that the condition codes are set
2037 according to the supplied comparison operation. We generate slightly
2038 different code for floating point comparisons, because a floating
2039 point operation cannot directly precede a @BF@. We assume the worst
2040 and fill that slot with a @NOP@.
2042 SPARC: Do not fill the delay slots here; you will confuse the register
2047 :: CLabel -- the branch target
2048 -> StixTree -- the condition on which to branch
2049 -> UniqSM InstrBlock
2051 #if alpha_TARGET_ARCH
2053 genCondJump lbl (StPrim op [x, StInt 0])
2054 = getRegister x `thenUs` \ register ->
2055 getNewRegNCG (registerRep register)
2058 code = registerCode register tmp
2059 value = registerName register tmp
2060 pk = registerRep register
2061 target = ImmCLbl lbl
2063 returnSeq code [BI (cmpOp op) value target]
2065 cmpOp CharGtOp = GTT
2067 cmpOp CharEqOp = EQQ
2069 cmpOp CharLtOp = LTT
2078 cmpOp WordGeOp = ALWAYS
2079 cmpOp WordEqOp = EQQ
2081 cmpOp WordLtOp = NEVER
2082 cmpOp WordLeOp = EQQ
2084 cmpOp AddrGeOp = ALWAYS
2085 cmpOp AddrEqOp = EQQ
2087 cmpOp AddrLtOp = NEVER
2088 cmpOp AddrLeOp = EQQ
2090 genCondJump lbl (StPrim op [x, StDouble 0.0])
2091 = getRegister x `thenUs` \ register ->
2092 getNewRegNCG (registerRep register)
2095 code = registerCode register tmp
2096 value = registerName register tmp
2097 pk = registerRep register
2098 target = ImmCLbl lbl
2100 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2102 cmpOp FloatGtOp = GTT
2103 cmpOp FloatGeOp = GE
2104 cmpOp FloatEqOp = EQQ
2105 cmpOp FloatNeOp = NE
2106 cmpOp FloatLtOp = LTT
2107 cmpOp FloatLeOp = LE
2108 cmpOp DoubleGtOp = GTT
2109 cmpOp DoubleGeOp = GE
2110 cmpOp DoubleEqOp = EQQ
2111 cmpOp DoubleNeOp = NE
2112 cmpOp DoubleLtOp = LTT
2113 cmpOp DoubleLeOp = LE
2115 genCondJump lbl (StPrim op [x, y])
2117 = trivialFCode pr instr x y `thenUs` \ register ->
2118 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2120 code = registerCode register tmp
2121 result = registerName register tmp
2122 target = ImmCLbl lbl
2124 returnUs (code . mkSeqInstr (BF cond result target))
2126 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2128 fltCmpOp op = case op of
2142 (instr, cond) = case op of
2143 FloatGtOp -> (FCMP TF LE, EQQ)
2144 FloatGeOp -> (FCMP TF LTT, EQQ)
2145 FloatEqOp -> (FCMP TF EQQ, NE)
2146 FloatNeOp -> (FCMP TF EQQ, EQQ)
2147 FloatLtOp -> (FCMP TF LTT, NE)
2148 FloatLeOp -> (FCMP TF LE, NE)
2149 DoubleGtOp -> (FCMP TF LE, EQQ)
2150 DoubleGeOp -> (FCMP TF LTT, EQQ)
2151 DoubleEqOp -> (FCMP TF EQQ, NE)
2152 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2153 DoubleLtOp -> (FCMP TF LTT, NE)
2154 DoubleLeOp -> (FCMP TF LE, NE)
2156 genCondJump lbl (StPrim op [x, y])
2157 = trivialCode instr x y `thenUs` \ register ->
2158 getNewRegNCG IntRep `thenUs` \ tmp ->
2160 code = registerCode register tmp
2161 result = registerName register tmp
2162 target = ImmCLbl lbl
2164 returnUs (code . mkSeqInstr (BI cond result target))
2166 (instr, cond) = case op of
2167 CharGtOp -> (CMP LE, EQQ)
2168 CharGeOp -> (CMP LTT, EQQ)
2169 CharEqOp -> (CMP EQQ, NE)
2170 CharNeOp -> (CMP EQQ, EQQ)
2171 CharLtOp -> (CMP LTT, NE)
2172 CharLeOp -> (CMP LE, NE)
2173 IntGtOp -> (CMP LE, EQQ)
2174 IntGeOp -> (CMP LTT, EQQ)
2175 IntEqOp -> (CMP EQQ, NE)
2176 IntNeOp -> (CMP EQQ, EQQ)
2177 IntLtOp -> (CMP LTT, NE)
2178 IntLeOp -> (CMP LE, NE)
2179 WordGtOp -> (CMP ULE, EQQ)
2180 WordGeOp -> (CMP ULT, EQQ)
2181 WordEqOp -> (CMP EQQ, NE)
2182 WordNeOp -> (CMP EQQ, EQQ)
2183 WordLtOp -> (CMP ULT, NE)
2184 WordLeOp -> (CMP ULE, NE)
2185 AddrGtOp -> (CMP ULE, EQQ)
2186 AddrGeOp -> (CMP ULT, EQQ)
2187 AddrEqOp -> (CMP EQQ, NE)
2188 AddrNeOp -> (CMP EQQ, EQQ)
2189 AddrLtOp -> (CMP ULT, NE)
2190 AddrLeOp -> (CMP ULE, NE)
2192 #endif {- alpha_TARGET_ARCH -}
2193 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2194 #if i386_TARGET_ARCH
2196 genCondJump lbl bool
2197 = getCondCode bool `thenUs` \ condition ->
2199 code = condCode condition
2200 cond = condName condition
2201 target = ImmCLbl lbl
2203 returnSeq code [JXX cond lbl]
2205 #endif {- i386_TARGET_ARCH -}
2206 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2207 #if sparc_TARGET_ARCH
2209 genCondJump lbl bool
2210 = getCondCode bool `thenUs` \ condition ->
2212 code = condCode condition
2213 cond = condName condition
2214 target = ImmCLbl lbl
2217 if condFloat condition then
2218 [NOP, BF cond False target, NOP]
2220 [BI cond False target, NOP]
2223 #endif {- sparc_TARGET_ARCH -}
2226 %************************************************************************
2228 \subsection{Generating C calls}
2230 %************************************************************************
2232 Now the biggest nightmare---calls. Most of the nastiness is buried in
2233 @get_arg@, which moves the arguments to the correct registers/stack
2234 locations. Apart from that, the code is easy.
2236 (If applicable) Do not fill the delay slots here; you will confuse the
2241 :: FAST_STRING -- function to call
2242 -> PrimRep -- type of the result
2243 -> [StixTree] -- arguments (of mixed type)
2244 -> UniqSM InstrBlock
2246 #if alpha_TARGET_ARCH
2248 genCCall fn kind args
2249 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2250 `thenUs` \ ((unused,_), argCode) ->
2252 nRegs = length allArgRegs - length unused
2253 code = asmParThen (map ($ asmVoid) argCode)
2256 LDA pv (AddrImm (ImmLab (ptext fn))),
2257 JSR ra (AddrReg pv) nRegs,
2258 LDGP gp (AddrReg ra)]
2260 ------------------------
2261 {- Try to get a value into a specific register (or registers) for
2262 a call. The first 6 arguments go into the appropriate
2263 argument register (separate registers for integer and floating
2264 point arguments, but used in lock-step), and the remaining
2265 arguments are dumped to the stack, beginning at 0(sp). Our
2266 first argument is a pair of the list of remaining argument
2267 registers to be assigned for this call and the next stack
2268 offset to use for overflowing arguments. This way,
2269 @get_Arg@ can be applied to all of a call's arguments using
2273 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2274 -> StixTree -- Current argument
2275 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2277 -- We have to use up all of our argument registers first...
2279 get_arg ((iDst,fDst):dsts, offset) arg
2280 = getRegister arg `thenUs` \ register ->
2282 reg = if isFloatingRep pk then fDst else iDst
2283 code = registerCode register reg
2284 src = registerName register reg
2285 pk = registerRep register
2288 if isFloatingRep pk then
2289 ((dsts, offset), if isFixed register then
2290 code . mkSeqInstr (FMOV src fDst)
2293 ((dsts, offset), if isFixed register then
2294 code . mkSeqInstr (OR src (RIReg src) iDst)
2297 -- Once we have run out of argument registers, we move to the
2300 get_arg ([], offset) arg
2301 = getRegister arg `thenUs` \ register ->
2302 getNewRegNCG (registerRep register)
2305 code = registerCode register tmp
2306 src = registerName register tmp
2307 pk = registerRep register
2308 sz = primRepToSize pk
2310 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2312 #endif {- alpha_TARGET_ARCH -}
2313 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2314 #if i386_TARGET_ARCH
2316 genCCall fn kind [StInt i]
2317 | fn == SLIT ("PerformGC_wrapper")
2319 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2320 CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2325 = getUniqLabelNCG `thenUs` \ lbl ->
2327 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2328 MOV L (OpImm (ImmCLbl lbl))
2329 -- this is hardwired
2330 (OpAddr (Address (Just ebx) Nothing (ImmInt 104))),
2331 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2337 genCCall fn kind args
2338 = mapUs get_call_arg args `thenUs` \ argCode ->
2341 {- OLD: Since there's no attempt at stealing %esp at the moment,
2342 restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
2343 (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2344 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Address (Just ebx) Nothing (ImmInt 80))),
2345 MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2349 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2350 call = [CALL fn__2 ,
2351 -- pop args; all args word sized?
2352 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2354 -- Don't restore %esp (see above)
2355 -- MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2358 returnSeq (code2) call
2360 -- function names that begin with '.' are assumed to be special
2361 -- internally generated names like '.mul,' which don't get an
2362 -- underscore prefix
2363 -- ToDo:needed (WDP 96/03) ???
2364 fn__2 = case (_HEAD_ fn) of
2365 '.' -> ImmLit (ptext fn)
2366 _ -> ImmLab (ptext fn)
2369 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2372 = get_op arg `thenUs` \ (code, op, sz) ->
2373 returnUs (code . mkSeqInstr (PUSH sz op))
2378 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2381 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2383 get_op (StInd pk mem)
2384 = getAmode mem `thenUs` \ amode ->
2386 code = amodeCode amode --asmVoid
2387 addr = amodeAddr amode
2388 sz = primRepToSize pk
2390 returnUs (code, OpAddr addr, sz)
2393 = getRegister op `thenUs` \ register ->
2394 getNewRegNCG (registerRep register)
2397 code = registerCode register tmp
2398 reg = registerName register tmp
2399 pk = registerRep register
2400 sz = primRepToSize pk
2402 returnUs (code, OpReg reg, sz)
2404 #endif {- i386_TARGET_ARCH -}
2405 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2406 #if sparc_TARGET_ARCH
2408 genCCall fn kind args
2409 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2410 `thenUs` \ ((unused,_), argCode) ->
2412 nRegs = length allArgRegs - length unused
2413 call = CALL fn__2 nRegs False
2414 code = asmParThen (map ($ asmVoid) argCode)
2416 returnSeq code [call, NOP]
2418 -- function names that begin with '.' are assumed to be special
2419 -- internally generated names like '.mul,' which don't get an
2420 -- underscore prefix
2421 -- ToDo:needed (WDP 96/03) ???
2422 fn__2 = case (_HEAD_ fn) of
2423 '.' -> ImmLit (ptext fn)
2424 _ -> ImmLab (ptext fn)
2426 ------------------------------------
2427 {- Try to get a value into a specific register (or registers) for
2428 a call. The SPARC calling convention is an absolute
2429 nightmare. The first 6x32 bits of arguments are mapped into
2430 %o0 through %o5, and the remaining arguments are dumped to the
2431 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2432 first argument is a pair of the list of remaining argument
2433 registers to be assigned for this call and the next stack
2434 offset to use for overflowing arguments. This way,
2435 @get_arg@ can be applied to all of a call's arguments using
2439 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2440 -> StixTree -- Current argument
2441 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2443 -- We have to use up all of our argument registers first...
2445 get_arg (dst:dsts, offset) arg
2446 = getRegister arg `thenUs` \ register ->
2447 getNewRegNCG (registerRep register)
2450 reg = if isFloatingRep pk then tmp else dst
2451 code = registerCode register reg
2452 src = registerName register reg
2453 pk = registerRep register
2455 returnUs (case pk of
2458 [] -> (([], offset + 1), code . mkSeqInstrs [
2459 -- conveniently put the second part in the right stack
2460 -- location, and load the first part into %o5
2461 ST DF src (spRel (offset - 1)),
2462 LD W (spRel (offset - 1)) dst])
2463 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2464 ST DF src (spRel (-2)),
2465 LD W (spRel (-2)) dst,
2466 LD W (spRel (-1)) dst__2])
2467 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2468 ST F src (spRel (-2)),
2469 LD W (spRel (-2)) dst])
2470 _ -> ((dsts, offset), if isFixed register then
2471 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2474 -- Once we have run out of argument registers, we move to the
2477 get_arg ([], offset) arg
2478 = getRegister arg `thenUs` \ register ->
2479 getNewRegNCG (registerRep register)
2482 code = registerCode register tmp
2483 src = registerName register tmp
2484 pk = registerRep register
2485 sz = primRepToSize pk
2486 words = if pk == DoubleRep then 2 else 1
2488 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2490 #endif {- sparc_TARGET_ARCH -}
2493 %************************************************************************
2495 \subsection{Support bits}
2497 %************************************************************************
2499 %************************************************************************
2501 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2503 %************************************************************************
2505 Turn those condition codes into integers now (when they appear on
2506 the right hand side of an assignment).
2508 (If applicable) Do not fill the delay slots here; you will confuse the
2512 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2514 #if alpha_TARGET_ARCH
2515 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2516 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2517 #endif {- alpha_TARGET_ARCH -}
2519 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2520 #if i386_TARGET_ARCH
2523 = condIntCode cond x y `thenUs` \ condition ->
2524 getNewRegNCG IntRep `thenUs` \ tmp ->
2525 --getRegister dst `thenUs` \ register ->
2527 --code2 = registerCode register tmp asmVoid
2528 --dst__2 = registerName register tmp
2529 code = condCode condition
2530 cond = condName condition
2531 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2532 code__2 dst = code . mkSeqInstrs [
2533 SETCC cond (OpReg tmp),
2534 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2535 MOV L (OpReg tmp) (OpReg dst)]
2537 returnUs (Any IntRep code__2)
2540 = getUniqLabelNCG `thenUs` \ lbl1 ->
2541 getUniqLabelNCG `thenUs` \ lbl2 ->
2542 condFltCode cond x y `thenUs` \ condition ->
2544 code = condCode condition
2545 cond = condName condition
2546 code__2 dst = code . mkSeqInstrs [
2548 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2551 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2554 returnUs (Any IntRep code__2)
2556 #endif {- i386_TARGET_ARCH -}
2557 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2558 #if sparc_TARGET_ARCH
2560 condIntReg EQQ x (StInt 0)
2561 = getRegister x `thenUs` \ register ->
2562 getNewRegNCG IntRep `thenUs` \ tmp ->
2564 code = registerCode register tmp
2565 src = registerName register tmp
2566 code__2 dst = code . mkSeqInstrs [
2567 SUB False True g0 (RIReg src) g0,
2568 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2570 returnUs (Any IntRep code__2)
2573 = getRegister x `thenUs` \ register1 ->
2574 getRegister y `thenUs` \ register2 ->
2575 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2576 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2578 code1 = registerCode register1 tmp1 asmVoid
2579 src1 = registerName register1 tmp1
2580 code2 = registerCode register2 tmp2 asmVoid
2581 src2 = registerName register2 tmp2
2582 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2583 XOR False src1 (RIReg src2) dst,
2584 SUB False True g0 (RIReg dst) g0,
2585 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2587 returnUs (Any IntRep code__2)
2589 condIntReg NE x (StInt 0)
2590 = getRegister x `thenUs` \ register ->
2591 getNewRegNCG IntRep `thenUs` \ tmp ->
2593 code = registerCode register tmp
2594 src = registerName register tmp
2595 code__2 dst = code . mkSeqInstrs [
2596 SUB False True g0 (RIReg src) g0,
2597 ADD True False g0 (RIImm (ImmInt 0)) dst]
2599 returnUs (Any IntRep code__2)
2602 = getRegister x `thenUs` \ register1 ->
2603 getRegister y `thenUs` \ register2 ->
2604 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2605 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2607 code1 = registerCode register1 tmp1 asmVoid
2608 src1 = registerName register1 tmp1
2609 code2 = registerCode register2 tmp2 asmVoid
2610 src2 = registerName register2 tmp2
2611 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2612 XOR False src1 (RIReg src2) dst,
2613 SUB False True g0 (RIReg dst) g0,
2614 ADD True False g0 (RIImm (ImmInt 0)) dst]
2616 returnUs (Any IntRep code__2)
2619 = getUniqLabelNCG `thenUs` \ lbl1 ->
2620 getUniqLabelNCG `thenUs` \ lbl2 ->
2621 condIntCode cond x y `thenUs` \ condition ->
2623 code = condCode condition
2624 cond = condName condition
2625 code__2 dst = code . mkSeqInstrs [
2626 BI cond False (ImmCLbl lbl1), NOP,
2627 OR False g0 (RIImm (ImmInt 0)) dst,
2628 BI ALWAYS False (ImmCLbl lbl2), NOP,
2630 OR False g0 (RIImm (ImmInt 1)) dst,
2633 returnUs (Any IntRep code__2)
2636 = getUniqLabelNCG `thenUs` \ lbl1 ->
2637 getUniqLabelNCG `thenUs` \ lbl2 ->
2638 condFltCode cond x y `thenUs` \ condition ->
2640 code = condCode condition
2641 cond = condName condition
2642 code__2 dst = code . mkSeqInstrs [
2644 BF cond False (ImmCLbl lbl1), NOP,
2645 OR False g0 (RIImm (ImmInt 0)) dst,
2646 BI ALWAYS False (ImmCLbl lbl2), NOP,
2648 OR False g0 (RIImm (ImmInt 1)) dst,
2651 returnUs (Any IntRep code__2)
2653 #endif {- sparc_TARGET_ARCH -}
2656 %************************************************************************
2658 \subsubsection{@trivial*Code@: deal with trivial instructions}
2660 %************************************************************************
2662 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2663 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2664 for constants on the right hand side, because that's where the generic
2665 optimizer will have put them.
2667 Similarly, for unary instructions, we don't have to worry about
2668 matching an StInt as the argument, because genericOpt will already
2669 have handled the constant-folding.
2673 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2674 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2675 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2677 -> StixTree -> StixTree -- the two arguments
2682 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2683 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2685 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2686 (Size -> Operand -> Instr)
2687 -> (Size -> Operand -> Instr) {-reversed instr-}
2689 -> Instr {-reversed instr: pop-}
2691 -> StixTree -> StixTree -- the two arguments
2695 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2696 ,IF_ARCH_i386 ((Operand -> Instr)
2697 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2699 -> StixTree -- the one argument
2704 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2705 ,IF_ARCH_i386 (Instr
2706 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2708 -> StixTree -- the one argument
2711 #if alpha_TARGET_ARCH
2713 trivialCode instr x (StInt y)
2715 = getRegister x `thenUs` \ register ->
2716 getNewRegNCG IntRep `thenUs` \ tmp ->
2718 code = registerCode register tmp
2719 src1 = registerName register tmp
2720 src2 = ImmInt (fromInteger y)
2721 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2723 returnUs (Any IntRep code__2)
2725 trivialCode instr x y
2726 = getRegister x `thenUs` \ register1 ->
2727 getRegister y `thenUs` \ register2 ->
2728 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2729 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2731 code1 = registerCode register1 tmp1 asmVoid
2732 src1 = registerName register1 tmp1
2733 code2 = registerCode register2 tmp2 asmVoid
2734 src2 = registerName register2 tmp2
2735 code__2 dst = asmParThen [code1, code2] .
2736 mkSeqInstr (instr src1 (RIReg src2) dst)
2738 returnUs (Any IntRep code__2)
2741 trivialUCode instr x
2742 = getRegister x `thenUs` \ register ->
2743 getNewRegNCG IntRep `thenUs` \ tmp ->
2745 code = registerCode register tmp
2746 src = registerName register tmp
2747 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2749 returnUs (Any IntRep code__2)
2752 trivialFCode _ instr x y
2753 = getRegister x `thenUs` \ register1 ->
2754 getRegister y `thenUs` \ register2 ->
2755 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2756 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2758 code1 = registerCode register1 tmp1
2759 src1 = registerName register1 tmp1
2761 code2 = registerCode register2 tmp2
2762 src2 = registerName register2 tmp2
2764 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2765 mkSeqInstr (instr src1 src2 dst)
2767 returnUs (Any DoubleRep code__2)
2769 trivialUFCode _ instr x
2770 = getRegister x `thenUs` \ register ->
2771 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2773 code = registerCode register tmp
2774 src = registerName register tmp
2775 code__2 dst = code . mkSeqInstr (instr src dst)
2777 returnUs (Any DoubleRep code__2)
2779 #endif {- alpha_TARGET_ARCH -}
2780 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2781 #if i386_TARGET_ARCH
2783 trivialCode instr x y
2785 = getRegister x `thenUs` \ register1 ->
2786 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2788 -- fixedname = registerName register1 eax
2789 code__2 dst = let code1 = registerCode register1 dst
2790 src1 = registerName register1 dst
2792 if isFixed register1 && src1 /= dst
2793 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2794 instr (OpImm imm__2) (OpReg dst)]
2796 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2798 returnUs (Any IntRep code__2)
2801 imm__2 = case imm of Just x -> x
2803 trivialCode instr x y
2805 = getRegister y `thenUs` \ register1 ->
2806 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2808 -- fixedname = registerName register1 eax
2809 code__2 dst = let code1 = registerCode register1 dst
2810 src1 = registerName register1 dst
2812 if isFixed register1 && src1 /= dst
2813 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2814 instr (OpImm imm__2) (OpReg dst)]
2816 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2818 returnUs (Any IntRep code__2)
2821 imm__2 = case imm of Just x -> x
2823 trivialCode instr x (StInd pk mem)
2824 = getRegister x `thenUs` \ register ->
2825 --getNewRegNCG IntRep `thenUs` \ tmp ->
2826 getAmode mem `thenUs` \ amode ->
2828 -- fixedname = registerName register eax
2829 code2 = amodeCode amode asmVoid
2830 src2 = amodeAddr amode
2831 code__2 dst = let code1 = registerCode register dst asmVoid
2832 src1 = registerName register dst
2833 in asmParThen [code1, code2] .
2834 if isFixed register && src1 /= dst
2835 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2836 instr (OpAddr src2) (OpReg dst)]
2838 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2840 returnUs (Any pk code__2)
2842 trivialCode instr (StInd pk mem) y
2843 = getRegister y `thenUs` \ register ->
2844 --getNewRegNCG IntRep `thenUs` \ tmp ->
2845 getAmode mem `thenUs` \ amode ->
2847 -- fixedname = registerName register eax
2848 code2 = amodeCode amode asmVoid
2849 src2 = amodeAddr amode
2851 code1 = registerCode register dst asmVoid
2852 src1 = registerName register dst
2853 in asmParThen [code1, code2] .
2854 if isFixed register && src1 /= dst
2855 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2856 instr (OpAddr src2) (OpReg dst)]
2858 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2860 returnUs (Any pk code__2)
2862 trivialCode instr x y
2863 = getRegister x `thenUs` \ register1 ->
2864 getRegister y `thenUs` \ register2 ->
2865 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2866 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2868 -- fixedname = registerName register1 eax
2869 code2 = registerCode register2 tmp2 asmVoid
2870 src2 = registerName register2 tmp2
2872 code1 = registerCode register1 dst asmVoid
2873 src1 = registerName register1 dst
2874 in asmParThen [code1, code2] .
2875 if isFixed register1 && src1 /= dst
2876 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2877 instr (OpReg src2) (OpReg dst)]
2879 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2881 returnUs (Any IntRep code__2)
2884 trivialUCode instr x
2885 = getRegister x `thenUs` \ register ->
2886 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2888 -- fixedname = registerName register eax
2890 code = registerCode register dst
2891 src = registerName register dst
2892 in code . if isFixed register && dst /= src
2893 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2895 else mkSeqInstr (instr (OpReg src))
2897 returnUs (Any IntRep code__2)
2900 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2901 = getRegister y `thenUs` \ register2 ->
2902 --getNewRegNCG (registerRep register2)
2903 -- `thenUs` \ tmp2 ->
2904 getAmode mem `thenUs` \ amode ->
2906 code1 = amodeCode amode
2907 src1 = amodeAddr amode
2910 code2 = registerCode register2 dst
2911 src2 = registerName register2 dst
2912 in asmParThen [code1 asmVoid,code2 asmVoid] .
2913 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2915 returnUs (Any pk code__2)
2917 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2918 = getRegister x `thenUs` \ register1 ->
2919 --getNewRegNCG (registerRep register1)
2920 -- `thenUs` \ tmp1 ->
2921 getAmode mem `thenUs` \ amode ->
2923 code2 = amodeCode amode
2924 src2 = amodeAddr amode
2927 code1 = registerCode register1 dst
2928 src1 = registerName register1 dst
2929 in asmParThen [code2 asmVoid,code1 asmVoid] .
2930 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2932 returnUs (Any pk code__2)
2934 trivialFCode pk _ _ _ instrpr x y
2935 = getRegister x `thenUs` \ register1 ->
2936 getRegister y `thenUs` \ register2 ->
2937 --getNewRegNCG (registerRep register1)
2938 -- `thenUs` \ tmp1 ->
2939 --getNewRegNCG (registerRep register2)
2940 -- `thenUs` \ tmp2 ->
2941 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2943 pk1 = registerRep register1
2944 code1 = registerCode register1 st0 --tmp1
2945 src1 = registerName register1 st0 --tmp1
2947 pk2 = registerRep register2
2950 code2 = registerCode register2 dst
2951 src2 = registerName register2 dst
2952 in asmParThen [code1 asmVoid, code2 asmVoid] .
2955 returnUs (Any pk1 code__2)
2958 trivialUFCode pk instr (StInd pk' mem)
2959 = getAmode mem `thenUs` \ amode ->
2961 code = amodeCode amode
2962 src = amodeAddr amode
2963 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2966 returnUs (Any pk code__2)
2968 trivialUFCode pk instr x
2969 = getRegister x `thenUs` \ register ->
2970 --getNewRegNCG pk `thenUs` \ tmp ->
2973 code = registerCode register dst
2974 src = registerName register dst
2975 in code . mkSeqInstrs [instr]
2977 returnUs (Any pk code__2)
2979 #endif {- i386_TARGET_ARCH -}
2980 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2981 #if sparc_TARGET_ARCH
2983 trivialCode instr x (StInt y)
2985 = getRegister x `thenUs` \ register ->
2986 getNewRegNCG IntRep `thenUs` \ tmp ->
2988 code = registerCode register tmp
2989 src1 = registerName register tmp
2990 src2 = ImmInt (fromInteger y)
2991 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2993 returnUs (Any IntRep code__2)
2995 trivialCode instr x y
2996 = getRegister x `thenUs` \ register1 ->
2997 getRegister y `thenUs` \ register2 ->
2998 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2999 getNewRegNCG IntRep `thenUs` \ tmp2 ->
3001 code1 = registerCode register1 tmp1 asmVoid
3002 src1 = registerName register1 tmp1
3003 code2 = registerCode register2 tmp2 asmVoid
3004 src2 = registerName register2 tmp2
3005 code__2 dst = asmParThen [code1, code2] .
3006 mkSeqInstr (instr src1 (RIReg src2) dst)
3008 returnUs (Any IntRep code__2)
3011 trivialFCode pk instr x y
3012 = getRegister x `thenUs` \ register1 ->
3013 getRegister y `thenUs` \ register2 ->
3014 getNewRegNCG (registerRep register1)
3016 getNewRegNCG (registerRep register2)
3018 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3020 promote x = asmInstr (FxTOy F DF x tmp)
3022 pk1 = registerRep register1
3023 code1 = registerCode register1 tmp1
3024 src1 = registerName register1 tmp1
3026 pk2 = registerRep register2
3027 code2 = registerCode register2 tmp2
3028 src2 = registerName register2 tmp2
3032 asmParThen [code1 asmVoid, code2 asmVoid] .
3033 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3034 else if pk1 == FloatRep then
3035 asmParThen [code1 (promote src1), code2 asmVoid] .
3036 mkSeqInstr (instr DF tmp src2 dst)
3038 asmParThen [code1 asmVoid, code2 (promote src2)] .
3039 mkSeqInstr (instr DF src1 tmp dst)
3041 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3044 trivialUCode instr x
3045 = getRegister x `thenUs` \ register ->
3046 getNewRegNCG IntRep `thenUs` \ tmp ->
3048 code = registerCode register tmp
3049 src = registerName register tmp
3050 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3052 returnUs (Any IntRep code__2)
3055 trivialUFCode pk instr x
3056 = getRegister x `thenUs` \ register ->
3057 getNewRegNCG pk `thenUs` \ tmp ->
3059 code = registerCode register tmp
3060 src = registerName register tmp
3061 code__2 dst = code . mkSeqInstr (instr src dst)
3063 returnUs (Any pk code__2)
3065 #endif {- sparc_TARGET_ARCH -}
3068 %************************************************************************
3070 \subsubsection{Coercing to/from integer/floating-point...}
3072 %************************************************************************
3074 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3075 to be generated. Here we just change the type on the Register passed
3076 on up. The code is machine-independent.
3078 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3079 conversions. We have to store temporaries in memory to move
3080 between the integer and the floating point register sets.
3083 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3084 coerceFltCode :: StixTree -> UniqSM Register
3086 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3087 coerceFP2Int :: StixTree -> UniqSM Register
3090 = getRegister x `thenUs` \ register ->
3093 Fixed _ reg code -> Fixed pk reg code
3094 Any _ code -> Any pk code
3099 = getRegister x `thenUs` \ register ->
3102 Fixed _ reg code -> Fixed DoubleRep reg code
3103 Any _ code -> Any DoubleRep code
3108 #if alpha_TARGET_ARCH
3111 = getRegister x `thenUs` \ register ->
3112 getNewRegNCG IntRep `thenUs` \ reg ->
3114 code = registerCode register reg
3115 src = registerName register reg
3117 code__2 dst = code . mkSeqInstrs [
3119 LD TF dst (spRel 0),
3122 returnUs (Any DoubleRep code__2)
3126 = getRegister x `thenUs` \ register ->
3127 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3129 code = registerCode register tmp
3130 src = registerName register tmp
3132 code__2 dst = code . mkSeqInstrs [
3134 ST TF tmp (spRel 0),
3137 returnUs (Any IntRep code__2)
3139 #endif {- alpha_TARGET_ARCH -}
3140 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3141 #if i386_TARGET_ARCH
3144 = getRegister x `thenUs` \ register ->
3145 getNewRegNCG IntRep `thenUs` \ reg ->
3147 code = registerCode register reg
3148 src = registerName register reg
3150 code__2 dst = code . mkSeqInstrs [
3151 -- to fix: should spill instead of using R1
3152 MOV L (OpReg src) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
3153 FILD (primRepToSize pk) (Address (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3155 returnUs (Any pk code__2)
3159 = getRegister x `thenUs` \ register ->
3160 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3162 code = registerCode register tmp
3163 src = registerName register tmp
3164 pk = registerRep register
3167 in code . mkSeqInstrs [
3169 FIST L (Address (Just ebx) Nothing (ImmInt OFFSET_R1)),
3170 MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3172 returnUs (Any IntRep code__2)
3174 #endif {- i386_TARGET_ARCH -}
3175 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3176 #if sparc_TARGET_ARCH
3179 = getRegister x `thenUs` \ register ->
3180 getNewRegNCG IntRep `thenUs` \ reg ->
3182 code = registerCode register reg
3183 src = registerName register reg
3185 code__2 dst = code . mkSeqInstrs [
3186 ST W src (spRel (-2)),
3187 LD W (spRel (-2)) dst,
3188 FxTOy W (primRepToSize pk) dst dst]
3190 returnUs (Any pk code__2)
3194 = getRegister x `thenUs` \ register ->
3195 getNewRegNCG IntRep `thenUs` \ reg ->
3196 getNewRegNCG FloatRep `thenUs` \ tmp ->
3198 code = registerCode register reg
3199 src = registerName register reg
3200 pk = registerRep register
3202 code__2 dst = code . mkSeqInstrs [
3203 FxTOy (primRepToSize pk) W src tmp,
3204 ST W tmp (spRel (-2)),
3205 LD W (spRel (-2)) dst]
3207 returnUs (Any IntRep code__2)
3209 #endif {- sparc_TARGET_ARCH -}
3212 %************************************************************************
3214 \subsubsection{Coercing integer to @Char@...}
3216 %************************************************************************
3218 Integer to character conversion. Where applicable, we try to do this
3219 in one step if the original object is in memory.
3222 chrCode :: StixTree -> UniqSM Register
3224 #if alpha_TARGET_ARCH
3227 = getRegister x `thenUs` \ register ->
3228 getNewRegNCG IntRep `thenUs` \ reg ->
3230 code = registerCode register reg
3231 src = registerName register reg
3232 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3234 returnUs (Any IntRep code__2)
3236 #endif {- alpha_TARGET_ARCH -}
3237 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3238 #if i386_TARGET_ARCH
3241 = getRegister x `thenUs` \ register ->
3242 --getNewRegNCG IntRep `thenUs` \ reg ->
3244 -- fixedname = registerName register eax
3246 code = registerCode register dst
3247 src = registerName register dst
3249 if isFixed register && src /= dst
3250 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3251 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3252 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3254 returnUs (Any IntRep code__2)
3256 #endif {- i386_TARGET_ARCH -}
3257 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3258 #if sparc_TARGET_ARCH
3260 chrCode (StInd pk mem)
3261 = getAmode mem `thenUs` \ amode ->
3263 code = amodeCode amode
3264 src = amodeAddr amode
3265 src_off = addrOffset src 3
3266 src__2 = case src_off of Just x -> x
3267 code__2 dst = if maybeToBool src_off then
3268 code . mkSeqInstr (LD BU src__2 dst)
3270 code . mkSeqInstrs [
3271 LD (primRepToSize pk) src dst,
3272 AND False dst (RIImm (ImmInt 255)) dst]
3274 returnUs (Any pk code__2)
3277 = getRegister x `thenUs` \ register ->
3278 getNewRegNCG IntRep `thenUs` \ reg ->
3280 code = registerCode register reg
3281 src = registerName register reg
3282 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3284 returnUs (Any IntRep code__2)
3286 #endif {- sparc_TARGET_ARCH -}
3289 %************************************************************************
3291 \subsubsection{Absolute value on integers}
3293 %************************************************************************
3295 Absolute value on integers, mostly for gmp size check macros. Again,
3296 the argument cannot be an StInt, because genericOpt already folded
3299 If applicable, do not fill the delay slots here; you will confuse the
3303 absIntCode :: StixTree -> UniqSM Register
3305 #if alpha_TARGET_ARCH
3306 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3307 #endif {- alpha_TARGET_ARCH -}
3309 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3310 #if i386_TARGET_ARCH
3313 = getRegister x `thenUs` \ register ->
3314 --getNewRegNCG IntRep `thenUs` \ reg ->
3315 getUniqLabelNCG `thenUs` \ lbl ->
3317 code__2 dst = let code = registerCode register dst
3318 src = registerName register dst
3319 in code . if isFixed register && dst /= src
3320 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3321 TEST L (OpReg dst) (OpReg dst),
3325 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3330 returnUs (Any IntRep code__2)
3332 #endif {- i386_TARGET_ARCH -}
3333 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3334 #if sparc_TARGET_ARCH
3337 = getRegister x `thenUs` \ register ->
3338 getNewRegNCG IntRep `thenUs` \ reg ->
3339 getUniqLabelNCG `thenUs` \ lbl ->
3341 code = registerCode register reg
3342 src = registerName register reg
3343 code__2 dst = code . mkSeqInstrs [
3344 SUB False True g0 (RIReg src) dst,
3345 BI GE False (ImmCLbl lbl), NOP,
3346 OR False g0 (RIReg src) dst,
3349 returnUs (Any IntRep code__2)
3351 #endif {- sparc_TARGET_ARCH -}