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, InstrList(..) ) where
19 import MachMisc -- may differ per-platform
22 import AbsCSyn ( MagicId )
23 import AbsCUtils ( magicIdPrimRep )
24 import CLabel ( isAsmTemp )
25 import Maybes ( maybeToBool, expectJust )
26 import OrdList -- quite a bit of it
27 import Pretty ( prettyToUn, ppRational )
28 import PrimRep ( isFloatingRep, PrimRep(..) )
29 import PrimOp ( PrimOp(..) )
30 import Stix ( getUniqLabelNCG, StixTree(..),
31 StixReg(..), CodeSegment(..)
33 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
34 mapAccumLUs, UniqSM(..)
36 import Unpretty ( uppPStr )
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 mangleIndexTree (StIndex pk base off)
132 = StPrim IntAddOp [base,
138 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
139 StPrim SllOp [off, StInt s]
143 shift _ = IF_ARCH_alpha(3,2)
147 maybeImm :: StixTree -> Maybe Imm
149 maybeImm (StLitLbl s) = Just (ImmLab s)
150 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
151 maybeImm (StCLbl l) = Just (ImmCLbl l)
154 | i >= toInteger minInt && i <= toInteger maxInt
155 = Just (ImmInt (fromInteger i))
157 = Just (ImmInteger i)
162 %************************************************************************
164 \subsection{The @Register@ type}
166 %************************************************************************
168 @Register@s passed up the tree. If the stix code forces the register
169 to live in a pre-decided machine register, it comes out as @Fixed@;
170 otherwise, it comes out as @Any@, and the parent can decide which
171 register to put it in.
175 = Fixed PrimRep Reg InstrBlock
176 | Any PrimRep (Reg -> InstrBlock)
178 registerCode :: Register -> Reg -> InstrBlock
179 registerCode (Fixed _ _ code) reg = code
180 registerCode (Any _ code) reg = code reg
182 registerName :: Register -> Reg -> Reg
183 registerName (Fixed _ reg _) _ = reg
184 registerName (Any _ _) reg = reg
186 registerRep :: Register -> PrimRep
187 registerRep (Fixed pk _ _) = pk
188 registerRep (Any pk _) = pk
190 isFixed :: Register -> Bool
191 isFixed (Fixed _ _ _) = True
192 isFixed (Any _ _) = False
195 Generate code to get a subtree into a @Register@:
197 getRegister :: StixTree -> UniqSM Register
199 getRegister (StReg (StixMagicId stgreg))
200 = case (magicIdRegMaybe stgreg) of
201 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
204 getRegister (StReg (StixTemp u pk))
205 = returnUs (Fixed pk (UnmappedReg u pk) id)
207 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
209 getRegister (StCall fn kind args)
210 = genCCall fn kind args `thenUs` \ call ->
211 returnUs (Fixed kind reg call)
213 reg = if isFloatingRep kind
214 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
215 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
217 getRegister (StString s)
218 = getUniqLabelNCG `thenUs` \ lbl ->
220 imm_lbl = ImmCLbl lbl
222 code dst = mkSeqInstrs [
225 ASCII True (_UNPK_ s),
227 #if alpha_TARGET_ARCH
228 LDA dst (AddrImm imm_lbl)
231 MOV L (OpImm imm_lbl) (OpReg dst)
233 #if sparc_TARGET_ARCH
234 SETHI (HI imm_lbl) dst,
235 OR False dst (RIImm (LO imm_lbl)) dst
239 returnUs (Any PtrRep code)
241 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
242 = getUniqLabelNCG `thenUs` \ lbl ->
244 imm_lbl = ImmCLbl lbl
246 code dst = mkSeqInstrs [
249 ASCII False (init xs),
251 #if alpha_TARGET_ARCH
252 LDA dst (AddrImm imm_lbl)
255 MOV L (OpImm imm_lbl) (OpReg dst)
257 #if sparc_TARGET_ARCH
258 SETHI (HI imm_lbl) dst,
259 OR False dst (RIImm (LO imm_lbl)) dst
263 returnUs (Any PtrRep code)
265 xs = _UNPK_ (_TAIL_ s)
267 -- end of machine-"independent" bit; here we go on the rest...
269 #if alpha_TARGET_ARCH
271 getRegister (StDouble d)
272 = getUniqLabelNCG `thenUs` \ lbl ->
273 getNewRegNCG PtrRep `thenUs` \ tmp ->
274 let code dst = mkSeqInstrs [
277 DATA TF [ImmLab (prettyToUn (ppRational d))],
279 LDA tmp (AddrImm (ImmCLbl lbl)),
280 LD TF dst (AddrReg tmp)]
282 returnUs (Any DoubleRep code)
284 getRegister (StPrim primop [x]) -- unary PrimOps
286 IntNegOp -> trivialUCode (NEG Q False) x
287 IntAbsOp -> trivialUCode (ABS Q) x
289 NotOp -> trivialUCode NOT x
291 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
292 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
294 OrdOp -> coerceIntCode IntRep x
297 Float2IntOp -> coerceFP2Int x
298 Int2FloatOp -> coerceInt2FP pr x
299 Double2IntOp -> coerceFP2Int x
300 Int2DoubleOp -> coerceInt2FP pr x
302 Double2FloatOp -> coerceFltCode x
303 Float2DoubleOp -> coerceFltCode x
305 other_op -> getRegister (StCall fn DoubleRep [x])
307 fn = case other_op of
308 FloatExpOp -> SLIT("exp")
309 FloatLogOp -> SLIT("log")
310 FloatSqrtOp -> SLIT("sqrt")
311 FloatSinOp -> SLIT("sin")
312 FloatCosOp -> SLIT("cos")
313 FloatTanOp -> SLIT("tan")
314 FloatAsinOp -> SLIT("asin")
315 FloatAcosOp -> SLIT("acos")
316 FloatAtanOp -> SLIT("atan")
317 FloatSinhOp -> SLIT("sinh")
318 FloatCoshOp -> SLIT("cosh")
319 FloatTanhOp -> SLIT("tanh")
320 DoubleExpOp -> SLIT("exp")
321 DoubleLogOp -> SLIT("log")
322 DoubleSqrtOp -> SLIT("sqrt")
323 DoubleSinOp -> SLIT("sin")
324 DoubleCosOp -> SLIT("cos")
325 DoubleTanOp -> SLIT("tan")
326 DoubleAsinOp -> SLIT("asin")
327 DoubleAcosOp -> SLIT("acos")
328 DoubleAtanOp -> SLIT("atan")
329 DoubleSinhOp -> SLIT("sinh")
330 DoubleCoshOp -> SLIT("cosh")
331 DoubleTanhOp -> SLIT("tanh")
333 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
335 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
337 CharGtOp -> trivialCode (CMP LT) y x
338 CharGeOp -> trivialCode (CMP LE) y x
339 CharEqOp -> trivialCode (CMP EQ) x y
340 CharNeOp -> int_NE_code x y
341 CharLtOp -> trivialCode (CMP LT) x y
342 CharLeOp -> trivialCode (CMP LE) x y
344 IntGtOp -> trivialCode (CMP LT) y x
345 IntGeOp -> trivialCode (CMP LE) y x
346 IntEqOp -> trivialCode (CMP EQ) x y
347 IntNeOp -> int_NE_code x y
348 IntLtOp -> trivialCode (CMP LT) x y
349 IntLeOp -> trivialCode (CMP LE) x y
351 WordGtOp -> trivialCode (CMP ULT) y x
352 WordGeOp -> trivialCode (CMP ULE) x y
353 WordEqOp -> trivialCode (CMP EQ) x y
354 WordNeOp -> int_NE_code x y
355 WordLtOp -> trivialCode (CMP ULT) x y
356 WordLeOp -> trivialCode (CMP ULE) x y
358 AddrGtOp -> trivialCode (CMP ULT) y x
359 AddrGeOp -> trivialCode (CMP ULE) y x
360 AddrEqOp -> trivialCode (CMP EQ) x y
361 AddrNeOp -> int_NE_code x y
362 AddrLtOp -> trivialCode (CMP ULT) x y
363 AddrLeOp -> trivialCode (CMP ULE) x y
365 FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y
366 FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y
367 FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y
368 FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y
369 FloatLtOp -> cmpF_code (FCMP TF LT) NE x y
370 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
372 DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y
373 DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y
374 DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y
375 DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y
376 DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y
377 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
379 IntAddOp -> trivialCode (ADD Q False) x y
380 IntSubOp -> trivialCode (SUB Q False) x y
381 IntMulOp -> trivialCode (MUL Q False) x y
382 IntQuotOp -> trivialCode (DIV Q False) x y
383 IntRemOp -> trivialCode (REM Q False) x y
385 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
386 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
387 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
388 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
390 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
391 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
392 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
393 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
395 AndOp -> trivialCode AND x y
396 OrOp -> trivialCode OR x y
397 SllOp -> trivialCode SLL x y
398 SraOp -> trivialCode SRA x y
399 SrlOp -> trivialCode SRL x y
401 ISllOp -> panic "AlphaGen:isll"
402 ISraOp -> panic "AlphaGen:isra"
403 ISrlOp -> panic "AlphaGen:isrl"
405 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
406 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
408 {- ------------------------------------------------------------
409 Some bizarre special code for getting condition codes into
410 registers. Integer non-equality is a test for equality
411 followed by an XOR with 1. (Integer comparisons always set
412 the result register to 0 or 1.) Floating point comparisons of
413 any kind leave the result in a floating point register, so we
414 need to wrangle an integer register out of things.
416 int_NE_code :: StixTree -> StixTree -> UniqSM Register
419 = trivialCode (CMP EQ) x y `thenUs` \ register ->
420 getNewRegNCG IntRep `thenUs` \ tmp ->
422 code = registerCode register tmp
423 src = registerName register tmp
424 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
426 returnUs (Any IntRep code__2)
428 {- ------------------------------------------------------------
429 Comments for int_NE_code also apply to cmpF_code
432 :: (Reg -> Reg -> Reg -> Instr)
434 -> StixTree -> StixTree
437 cmpF_code instr cond x y
438 = trivialFCode pr instr x y `thenUs` \ register ->
439 getNewRegNCG DoubleRep `thenUs` \ tmp ->
440 getUniqLabelNCG `thenUs` \ lbl ->
442 code = registerCode register tmp
443 result = registerName register tmp
445 code__2 dst = code . mkSeqInstrs [
446 OR zero (RIImm (ImmInt 1)) dst,
447 BF cond result (ImmCLbl lbl),
448 OR zero (RIReg zero) dst,
451 returnUs (Any IntRep code__2)
453 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
454 ------------------------------------------------------------
456 getRegister (StInd pk mem)
457 = getAmode mem `thenUs` \ amode ->
459 code = amodeCode amode
460 src = amodeAddr amode
461 size = primRepToSize pk
462 code__2 dst = code . mkSeqInstr (LD size dst src)
464 returnUs (Any pk code__2)
466 getRegister (StInt i)
469 code dst = mkSeqInstr (OR zero (RIImm src) dst)
471 returnUs (Any IntRep code)
474 code dst = mkSeqInstr (LDI Q dst src)
476 returnUs (Any IntRep code)
478 src = ImmInt (fromInteger i)
483 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
485 returnUs (Any PtrRep code)
488 imm__2 = case imm of Just x -> x
490 #endif {- alpha_TARGET_ARCH -}
491 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
494 getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
496 getRegister (StDouble 0.0)
498 code dst = mkSeqInstrs [FLDZ]
500 returnUs (Any DoubleRep code)
502 getRegister (StDouble 1.0)
504 code dst = mkSeqInstrs [FLD1]
506 returnUs (Any DoubleRep code)
508 getRegister (StDouble d)
509 = getUniqLabelNCG `thenUs` \ lbl ->
510 --getNewRegNCG PtrRep `thenUs` \ tmp ->
511 let code dst = mkSeqInstrs [
514 DATA DF [dblImmLit d],
516 FLD DF (OpImm (ImmCLbl lbl))
519 returnUs (Any DoubleRep code)
521 getRegister (StPrim primop [x]) -- unary PrimOps
523 IntNegOp -> trivialUCode (NEGI L) x
524 IntAbsOp -> absIntCode x
526 NotOp -> trivialUCode (NOT L) x
528 FloatNegOp -> trivialUFCode FloatRep FCHS x
529 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
530 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
532 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
534 OrdOp -> coerceIntCode IntRep x
537 Float2IntOp -> coerceFP2Int x
538 Int2FloatOp -> coerceInt2FP FloatRep x
539 Double2IntOp -> coerceFP2Int x
540 Int2DoubleOp -> coerceInt2FP DoubleRep x
542 Double2FloatOp -> coerceFltCode x
543 Float2DoubleOp -> coerceFltCode x
547 fixed_x = if is_float_op -- promote to double
548 then StPrim Float2DoubleOp [x]
551 getRegister (StCall fn DoubleRep [x])
555 FloatExpOp -> (True, SLIT("exp"))
556 FloatLogOp -> (True, SLIT("log"))
558 FloatSinOp -> (True, SLIT("sin"))
559 FloatCosOp -> (True, SLIT("cos"))
560 FloatTanOp -> (True, SLIT("tan"))
562 FloatAsinOp -> (True, SLIT("asin"))
563 FloatAcosOp -> (True, SLIT("acos"))
564 FloatAtanOp -> (True, SLIT("atan"))
566 FloatSinhOp -> (True, SLIT("sinh"))
567 FloatCoshOp -> (True, SLIT("cosh"))
568 FloatTanhOp -> (True, SLIT("tanh"))
570 DoubleExpOp -> (False, SLIT("exp"))
571 DoubleLogOp -> (False, SLIT("log"))
573 DoubleSinOp -> (False, SLIT("sin"))
574 DoubleCosOp -> (False, SLIT("cos"))
575 DoubleTanOp -> (False, SLIT("tan"))
577 DoubleAsinOp -> (False, SLIT("asin"))
578 DoubleAcosOp -> (False, SLIT("acos"))
579 DoubleAtanOp -> (False, SLIT("atan"))
581 DoubleSinhOp -> (False, SLIT("sinh"))
582 DoubleCoshOp -> (False, SLIT("cosh"))
583 DoubleTanhOp -> (False, SLIT("tanh"))
585 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
587 CharGtOp -> condIntReg GT x y
588 CharGeOp -> condIntReg GE x y
589 CharEqOp -> condIntReg EQ x y
590 CharNeOp -> condIntReg NE x y
591 CharLtOp -> condIntReg LT x y
592 CharLeOp -> condIntReg LE x y
594 IntGtOp -> condIntReg GT x y
595 IntGeOp -> condIntReg GE x y
596 IntEqOp -> condIntReg EQ x y
597 IntNeOp -> condIntReg NE x y
598 IntLtOp -> condIntReg LT x y
599 IntLeOp -> condIntReg LE x y
601 WordGtOp -> condIntReg GU x y
602 WordGeOp -> condIntReg GEU x y
603 WordEqOp -> condIntReg EQ x y
604 WordNeOp -> condIntReg NE x y
605 WordLtOp -> condIntReg LU x y
606 WordLeOp -> condIntReg LEU x y
608 AddrGtOp -> condIntReg GU x y
609 AddrGeOp -> condIntReg GEU x y
610 AddrEqOp -> condIntReg EQ x y
611 AddrNeOp -> condIntReg NE x y
612 AddrLtOp -> condIntReg LU x y
613 AddrLeOp -> condIntReg LEU x y
615 FloatGtOp -> condFltReg GT x y
616 FloatGeOp -> condFltReg GE x y
617 FloatEqOp -> condFltReg EQ x y
618 FloatNeOp -> condFltReg NE x y
619 FloatLtOp -> condFltReg LT x y
620 FloatLeOp -> condFltReg LE x y
622 DoubleGtOp -> condFltReg GT x y
623 DoubleGeOp -> condFltReg GE x y
624 DoubleEqOp -> condFltReg EQ x y
625 DoubleNeOp -> condFltReg NE x y
626 DoubleLtOp -> condFltReg LT x y
627 DoubleLeOp -> condFltReg LE x y
629 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
630 -- this should be optimised by the generic Opts,
631 -- I don't know why it is not (sometimes)!
633 [x, StInt 0] -> getRegister x
638 IntSubOp -> sub_code L x y
639 IntQuotOp -> quot_code L x y True{-division-}
640 IntRemOp -> quot_code L x y False{-remainder-}
641 IntMulOp -> trivialCode (IMUL L) x y {-True-}
643 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
644 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
645 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
646 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
648 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
649 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
650 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
651 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
653 AndOp -> trivialCode (AND L) x y {-True-}
654 OrOp -> trivialCode (OR L) x y {-True-}
655 SllOp -> trivialCode (SHL L) x y {-False-}
656 SraOp -> trivialCode (SAR L) x y {-False-}
657 SrlOp -> trivialCode (SHR L) x y {-False-}
659 ISllOp -> panic "I386Gen:isll"
660 ISraOp -> panic "I386Gen:isra"
661 ISrlOp -> panic "I386Gen:isrl"
663 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
664 where promote x = StPrim Float2DoubleOp [x]
665 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
667 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
669 add_code sz x (StInt y)
670 = getRegister x `thenUs` \ register ->
671 getNewRegNCG IntRep `thenUs` \ tmp ->
673 code = registerCode register tmp
674 src1 = registerName register tmp
675 src2 = ImmInt (fromInteger y)
677 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
679 returnUs (Any IntRep code__2)
681 add_code sz x (StInd _ mem)
682 = getRegister x `thenUs` \ register1 ->
683 --getNewRegNCG (registerRep register1)
684 -- `thenUs` \ tmp1 ->
685 getAmode mem `thenUs` \ amode ->
687 code2 = amodeCode amode
688 src2 = amodeAddr amode
690 fixedname = registerName register1 eax
691 code__2 dst = let code1 = registerCode register1 dst
692 src1 = registerName register1 dst
693 in asmParThen [code2 asmVoid,code1 asmVoid] .
694 if isFixed register1 && src1 /= dst
695 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
696 ADD sz (OpAddr src2) (OpReg dst)]
698 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
700 returnUs (Any IntRep code__2)
702 add_code sz (StInd _ mem) y
703 = getRegister y `thenUs` \ register2 ->
704 --getNewRegNCG (registerRep register2)
705 -- `thenUs` \ tmp2 ->
706 getAmode mem `thenUs` \ amode ->
708 code1 = amodeCode amode
709 src1 = amodeAddr amode
711 fixedname = registerName register2 eax
712 code__2 dst = let code2 = registerCode register2 dst
713 src2 = registerName register2 dst
714 in asmParThen [code1 asmVoid,code2 asmVoid] .
715 if isFixed register2 && src2 /= dst
716 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
717 ADD sz (OpAddr src1) (OpReg dst)]
719 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
721 returnUs (Any IntRep code__2)
724 = getRegister x `thenUs` \ register1 ->
725 getRegister y `thenUs` \ register2 ->
726 getNewRegNCG IntRep `thenUs` \ tmp1 ->
727 getNewRegNCG IntRep `thenUs` \ tmp2 ->
729 code1 = registerCode register1 tmp1 asmVoid
730 src1 = registerName register1 tmp1
731 code2 = registerCode register2 tmp2 asmVoid
732 src2 = registerName register2 tmp2
733 code__2 dst = asmParThen [code1, code2] .
734 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
736 returnUs (Any IntRep code__2)
739 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
741 sub_code sz x (StInt y)
742 = getRegister x `thenUs` \ register ->
743 getNewRegNCG IntRep `thenUs` \ tmp ->
745 code = registerCode register tmp
746 src1 = registerName register tmp
747 src2 = ImmInt (-(fromInteger y))
749 mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
751 returnUs (Any IntRep code__2)
753 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
758 -> StixTree -> StixTree
759 -> Bool -- True => division, False => remainder operation
762 -- x must go into eax, edx must be a sign-extension of eax, and y
763 -- should go in some other register (or memory), so that we get
764 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
765 -- put y in memory (if it is not there already)
767 quot_code sz x (StInd pk mem) is_division
768 = getRegister x `thenUs` \ register1 ->
769 getNewRegNCG IntRep `thenUs` \ tmp1 ->
770 getAmode mem `thenUs` \ amode ->
772 code1 = registerCode register1 tmp1 asmVoid
773 src1 = registerName register1 tmp1
774 code2 = amodeCode amode asmVoid
775 src2 = amodeAddr amode
776 code__2 = asmParThen [code1, code2] .
777 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
779 IDIV sz (OpAddr src2)]
781 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
783 quot_code sz x (StInt i) is_division
784 = getRegister x `thenUs` \ register1 ->
785 getNewRegNCG IntRep `thenUs` \ tmp1 ->
787 code1 = registerCode register1 tmp1 asmVoid
788 src1 = registerName register1 tmp1
789 src2 = ImmInt (fromInteger i)
790 code__2 = asmParThen [code1] .
791 mkSeqInstrs [-- we put src2 in (ebx)
792 MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
793 MOV L (OpReg src1) (OpReg eax),
795 IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
797 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
799 quot_code sz x y is_division
800 = getRegister x `thenUs` \ register1 ->
801 getNewRegNCG IntRep `thenUs` \ tmp1 ->
802 getRegister y `thenUs` \ register2 ->
803 getNewRegNCG IntRep `thenUs` \ tmp2 ->
805 code1 = registerCode register1 tmp1 asmVoid
806 src1 = registerName register1 tmp1
807 code2 = registerCode register2 tmp2 asmVoid
808 src2 = registerName register2 tmp2
809 code__2 = asmParThen [code1, code2] .
810 if src2 == ecx || src2 == esi
811 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
813 IDIV sz (OpReg src2)]
814 else mkSeqInstrs [ -- we put src2 in (ebx)
815 MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
816 MOV L (OpReg src1) (OpReg eax),
818 IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
820 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
821 -----------------------
823 getRegister (StInd pk mem)
824 = getAmode mem `thenUs` \ amode ->
826 code = amodeCode amode
827 src = amodeAddr amode
828 size = primRepToSize pk
830 if pk == DoubleRep || pk == FloatRep
831 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
832 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
834 returnUs (Any pk code__2)
837 getRegister (StInt i)
839 src = ImmInt (fromInteger i)
840 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
842 returnUs (Any IntRep code)
847 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
849 returnUs (Any PtrRep code)
852 imm__2 = case imm of Just x -> x
854 #endif {- i386_TARGET_ARCH -}
855 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
856 #if sparc_TARGET_ARCH
858 getRegister (StDouble d)
859 = getUniqLabelNCG `thenUs` \ lbl ->
860 getNewRegNCG PtrRep `thenUs` \ tmp ->
861 let code dst = mkSeqInstrs [
864 DATA DF [dblImmLit d],
866 SETHI (HI (ImmCLbl lbl)) tmp,
867 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
869 returnUs (Any DoubleRep code)
871 getRegister (StPrim primop [x]) -- unary PrimOps
873 IntNegOp -> trivialUCode (SUB False False g0) x
874 IntAbsOp -> absIntCode x
876 NotOp -> trivialUCode (XNOR False g0) x
878 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
879 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
881 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
882 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
884 OrdOp -> coerceIntCode IntRep x
887 Float2IntOp -> coerceFP2Int x
888 Int2FloatOp -> coerceInt2FP FloatRep x
889 Double2IntOp -> coerceFP2Int x
890 Int2DoubleOp -> coerceInt2FP DoubleRep x
894 fixed_x = if is_float_op -- promote to double
895 then StPrim Float2DoubleOp [x]
898 getRegister (StCall fn DoubleRep [x])
902 FloatExpOp -> (True, SLIT("exp"))
903 FloatLogOp -> (True, SLIT("log"))
905 FloatSinOp -> (True, SLIT("sin"))
906 FloatCosOp -> (True, SLIT("cos"))
907 FloatTanOp -> (True, SLIT("tan"))
909 FloatAsinOp -> (True, SLIT("asin"))
910 FloatAcosOp -> (True, SLIT("acos"))
911 FloatAtanOp -> (True, SLIT("atan"))
913 FloatSinhOp -> (True, SLIT("sinh"))
914 FloatCoshOp -> (True, SLIT("cosh"))
915 FloatTanhOp -> (True, SLIT("tanh"))
917 DoubleExpOp -> (False, SLIT("exp"))
918 DoubleLogOp -> (False, SLIT("log"))
920 DoubleSinOp -> (False, SLIT("sin"))
921 DoubleCosOp -> (False, SLIT("cos"))
922 DoubleTanOp -> (False, SLIT("tan"))
924 DoubleAsinOp -> (False, SLIT("asin"))
925 DoubleAcosOp -> (False, SLIT("acos"))
926 DoubleAtanOp -> (False, SLIT("atan"))
928 DoubleSinhOp -> (False, SLIT("sinh"))
929 DoubleCoshOp -> (False, SLIT("cosh"))
930 DoubleTanhOp -> (False, SLIT("tanh"))
932 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
934 CharGtOp -> condIntReg GT x y
935 CharGeOp -> condIntReg GE x y
936 CharEqOp -> condIntReg EQ x y
937 CharNeOp -> condIntReg NE x y
938 CharLtOp -> condIntReg LT x y
939 CharLeOp -> condIntReg LE x y
941 IntGtOp -> condIntReg GT x y
942 IntGeOp -> condIntReg GE x y
943 IntEqOp -> condIntReg EQ x y
944 IntNeOp -> condIntReg NE x y
945 IntLtOp -> condIntReg LT x y
946 IntLeOp -> condIntReg LE x y
948 WordGtOp -> condIntReg GU x y
949 WordGeOp -> condIntReg GEU x y
950 WordEqOp -> condIntReg EQ x y
951 WordNeOp -> condIntReg NE x y
952 WordLtOp -> condIntReg LU x y
953 WordLeOp -> condIntReg LEU x y
955 AddrGtOp -> condIntReg GU x y
956 AddrGeOp -> condIntReg GEU x y
957 AddrEqOp -> condIntReg EQ x y
958 AddrNeOp -> condIntReg NE x y
959 AddrLtOp -> condIntReg LU x y
960 AddrLeOp -> condIntReg LEU x y
962 FloatGtOp -> condFltReg GT x y
963 FloatGeOp -> condFltReg GE x y
964 FloatEqOp -> condFltReg EQ x y
965 FloatNeOp -> condFltReg NE x y
966 FloatLtOp -> condFltReg LT x y
967 FloatLeOp -> condFltReg LE x y
969 DoubleGtOp -> condFltReg GT x y
970 DoubleGeOp -> condFltReg GE x y
971 DoubleEqOp -> condFltReg EQ x y
972 DoubleNeOp -> condFltReg NE x y
973 DoubleLtOp -> condFltReg LT x y
974 DoubleLeOp -> condFltReg LE x y
976 IntAddOp -> trivialCode (ADD False False) x y
977 IntSubOp -> trivialCode (SUB False False) x y
979 -- ToDo: teach about V8+ SPARC mul/div instructions
980 IntMulOp -> imul_div SLIT(".umul") x y
981 IntQuotOp -> imul_div SLIT(".div") x y
982 IntRemOp -> imul_div SLIT(".rem") x y
984 FloatAddOp -> trivialFCode FloatRep FADD x y
985 FloatSubOp -> trivialFCode FloatRep FSUB x y
986 FloatMulOp -> trivialFCode FloatRep FMUL x y
987 FloatDivOp -> trivialFCode FloatRep FDIV x y
989 DoubleAddOp -> trivialFCode DoubleRep FADD x y
990 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
991 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
992 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
994 AndOp -> trivialCode (AND False) x y
995 OrOp -> trivialCode (OR False) x y
996 SllOp -> trivialCode SLL x y
997 SraOp -> trivialCode SRA x y
998 SrlOp -> trivialCode SRL x y
1000 ISllOp -> panic "SparcGen:isll"
1001 ISraOp -> panic "SparcGen:isra"
1002 ISrlOp -> panic "SparcGen:isrl"
1004 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1005 where promote x = StPrim Float2DoubleOp [x]
1006 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1008 imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1010 getRegister (StInd pk mem)
1011 = getAmode mem `thenUs` \ amode ->
1013 code = amodeCode amode
1014 src = amodeAddr amode
1015 size = primRepToSize pk
1016 code__2 dst = code . mkSeqInstr (LD size src dst)
1018 returnUs (Any pk code__2)
1020 getRegister (StInt i)
1023 src = ImmInt (fromInteger i)
1024 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1026 returnUs (Any IntRep code)
1031 code dst = mkSeqInstrs [
1032 SETHI (HI imm__2) dst,
1033 OR False dst (RIImm (LO imm__2)) dst]
1035 returnUs (Any PtrRep code)
1038 imm__2 = case imm of Just x -> x
1040 #endif {- sparc_TARGET_ARCH -}
1043 %************************************************************************
1045 \subsection{The @Amode@ type}
1047 %************************************************************************
1049 @Amode@s: Memory addressing modes passed up the tree.
1051 data Amode = Amode Addr InstrBlock
1053 amodeAddr (Amode addr _) = addr
1054 amodeCode (Amode _ code) = code
1057 Now, given a tree (the argument to an StInd) that references memory,
1058 produce a suitable addressing mode.
1061 getAmode :: StixTree -> UniqSM Amode
1063 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1065 #if alpha_TARGET_ARCH
1067 getAmode (StPrim IntSubOp [x, StInt i])
1068 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1069 getRegister x `thenUs` \ register ->
1071 code = registerCode register tmp
1072 reg = registerName register tmp
1073 off = ImmInt (-(fromInteger i))
1075 returnUs (Amode (AddrRegImm reg off) code)
1077 getAmode (StPrim IntAddOp [x, StInt i])
1078 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1079 getRegister x `thenUs` \ register ->
1081 code = registerCode register tmp
1082 reg = registerName register tmp
1083 off = ImmInt (fromInteger i)
1085 returnUs (Amode (AddrRegImm reg off) code)
1089 = returnUs (Amode (AddrImm imm__2) id)
1092 imm__2 = case imm of Just x -> x
1095 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1096 getRegister other `thenUs` \ register ->
1098 code = registerCode register tmp
1099 reg = registerName register tmp
1101 returnUs (Amode (AddrReg reg) code)
1103 #endif {- alpha_TARGET_ARCH -}
1104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1105 #if i386_TARGET_ARCH
1107 getAmode (StPrim IntSubOp [x, StInt i])
1108 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1109 getRegister x `thenUs` \ register ->
1111 code = registerCode register tmp
1112 reg = registerName register tmp
1113 off = ImmInt (-(fromInteger i))
1115 returnUs (Amode (Addr (Just reg) Nothing off) code)
1117 getAmode (StPrim IntAddOp [x, StInt i])
1120 code = mkSeqInstrs []
1122 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1125 imm__2 = case imm of Just x -> x
1127 getAmode (StPrim IntAddOp [x, StInt i])
1128 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1129 getRegister x `thenUs` \ register ->
1131 code = registerCode register tmp
1132 reg = registerName register tmp
1133 off = ImmInt (fromInteger i)
1135 returnUs (Amode (Addr (Just reg) Nothing off) code)
1137 getAmode (StPrim IntAddOp [x, y])
1138 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1139 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1140 getRegister x `thenUs` \ register1 ->
1141 getRegister y `thenUs` \ register2 ->
1143 code1 = registerCode register1 tmp1 asmVoid
1144 reg1 = registerName register1 tmp1
1145 code2 = registerCode register2 tmp2 asmVoid
1146 reg2 = registerName register2 tmp2
1147 code__2 = asmParThen [code1, code2]
1149 returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1154 code = mkSeqInstrs []
1156 returnUs (Amode (ImmAddr imm__2 0) code)
1159 imm__2 = case imm of Just x -> x
1162 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1163 getRegister other `thenUs` \ register ->
1165 code = registerCode register tmp
1166 reg = registerName register tmp
1169 returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
1171 #endif {- i386_TARGET_ARCH -}
1172 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1173 #if sparc_TARGET_ARCH
1175 getAmode (StPrim IntSubOp [x, StInt i])
1177 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1178 getRegister x `thenUs` \ register ->
1180 code = registerCode register tmp
1181 reg = registerName register tmp
1182 off = ImmInt (-(fromInteger i))
1184 returnUs (Amode (AddrRegImm reg off) code)
1187 getAmode (StPrim IntAddOp [x, StInt i])
1189 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1190 getRegister x `thenUs` \ register ->
1192 code = registerCode register tmp
1193 reg = registerName register tmp
1194 off = ImmInt (fromInteger i)
1196 returnUs (Amode (AddrRegImm reg off) code)
1198 getAmode (StPrim IntAddOp [x, y])
1199 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1200 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1201 getRegister x `thenUs` \ register1 ->
1202 getRegister y `thenUs` \ register2 ->
1204 code1 = registerCode register1 tmp1 asmVoid
1205 reg1 = registerName register1 tmp1
1206 code2 = registerCode register2 tmp2 asmVoid
1207 reg2 = registerName register2 tmp2
1208 code__2 = asmParThen [code1, code2]
1210 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1214 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1216 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1218 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1221 imm__2 = case imm of Just x -> x
1224 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1225 getRegister other `thenUs` \ register ->
1227 code = registerCode register tmp
1228 reg = registerName register tmp
1231 returnUs (Amode (AddrRegImm reg off) code)
1233 #endif {- sparc_TARGET_ARCH -}
1236 %************************************************************************
1238 \subsection{The @CondCode@ type}
1240 %************************************************************************
1242 Condition codes passed up the tree.
1244 data CondCode = CondCode Bool Cond InstrBlock
1246 condName (CondCode _ cond _) = cond
1247 condFloat (CondCode is_float _ _) = is_float
1248 condCode (CondCode _ _ code) = code
1251 Set up a condition code for a conditional branch.
1254 getCondCode :: StixTree -> UniqSM CondCode
1256 #if alpha_TARGET_ARCH
1257 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1258 #endif {- alpha_TARGET_ARCH -}
1259 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1261 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1262 -- yes, they really do seem to want exactly the same!
1264 getCondCode (StPrim primop [x, y])
1266 CharGtOp -> condIntCode GT x y
1267 CharGeOp -> condIntCode GE x y
1268 CharEqOp -> condIntCode EQ x y
1269 CharNeOp -> condIntCode NE x y
1270 CharLtOp -> condIntCode LT x y
1271 CharLeOp -> condIntCode LE x y
1273 IntGtOp -> condIntCode GT x y
1274 IntGeOp -> condIntCode GE x y
1275 IntEqOp -> condIntCode EQ x y
1276 IntNeOp -> condIntCode NE x y
1277 IntLtOp -> condIntCode LT x y
1278 IntLeOp -> condIntCode LE x y
1280 WordGtOp -> condIntCode GU x y
1281 WordGeOp -> condIntCode GEU x y
1282 WordEqOp -> condIntCode EQ x y
1283 WordNeOp -> condIntCode NE x y
1284 WordLtOp -> condIntCode LU x y
1285 WordLeOp -> condIntCode LEU x y
1287 AddrGtOp -> condIntCode GU x y
1288 AddrGeOp -> condIntCode GEU x y
1289 AddrEqOp -> condIntCode EQ x y
1290 AddrNeOp -> condIntCode NE x y
1291 AddrLtOp -> condIntCode LU x y
1292 AddrLeOp -> condIntCode LEU x y
1294 FloatGtOp -> condFltCode GT x y
1295 FloatGeOp -> condFltCode GE x y
1296 FloatEqOp -> condFltCode EQ x y
1297 FloatNeOp -> condFltCode NE x y
1298 FloatLtOp -> condFltCode LT x y
1299 FloatLeOp -> condFltCode LE x y
1301 DoubleGtOp -> condFltCode GT x y
1302 DoubleGeOp -> condFltCode GE x y
1303 DoubleEqOp -> condFltCode EQ x y
1304 DoubleNeOp -> condFltCode NE x y
1305 DoubleLtOp -> condFltCode LT x y
1306 DoubleLeOp -> condFltCode LE x y
1308 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1313 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1314 passed back up the tree.
1317 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1319 #if alpha_TARGET_ARCH
1320 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1321 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1322 #endif {- alpha_TARGET_ARCH -}
1324 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1325 #if i386_TARGET_ARCH
1327 condIntCode cond (StInd _ x) y
1329 = getAmode x `thenUs` \ amode ->
1331 code1 = amodeCode amode asmVoid
1332 y__2 = amodeAddr amode
1333 code__2 = asmParThen [code1] .
1334 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1336 returnUs (CondCode False cond code__2)
1339 imm__2 = case imm of Just x -> x
1341 condIntCode cond x (StInt 0)
1342 = getRegister x `thenUs` \ register1 ->
1343 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1345 code1 = registerCode register1 tmp1 asmVoid
1346 src1 = registerName register1 tmp1
1347 code__2 = asmParThen [code1] .
1348 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1350 returnUs (CondCode False cond code__2)
1352 condIntCode cond x y
1354 = getRegister x `thenUs` \ register1 ->
1355 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1357 code1 = registerCode register1 tmp1 asmVoid
1358 src1 = registerName register1 tmp1
1359 code__2 = asmParThen [code1] .
1360 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1362 returnUs (CondCode False cond code__2)
1365 imm__2 = case imm of Just x -> x
1367 condIntCode cond (StInd _ x) y
1368 = getAmode x `thenUs` \ amode ->
1369 getRegister y `thenUs` \ register2 ->
1370 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1372 code1 = amodeCode amode asmVoid
1373 src1 = amodeAddr amode
1374 code2 = registerCode register2 tmp2 asmVoid
1375 src2 = registerName register2 tmp2
1376 code__2 = asmParThen [code1, code2] .
1377 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1379 returnUs (CondCode False cond code__2)
1381 condIntCode cond y (StInd _ x)
1382 = getAmode x `thenUs` \ amode ->
1383 getRegister y `thenUs` \ register2 ->
1384 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1386 code1 = amodeCode amode asmVoid
1387 src1 = amodeAddr amode
1388 code2 = registerCode register2 tmp2 asmVoid
1389 src2 = registerName register2 tmp2
1390 code__2 = asmParThen [code1, code2] .
1391 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1393 returnUs (CondCode False cond code__2)
1395 condIntCode cond x y
1396 = getRegister x `thenUs` \ register1 ->
1397 getRegister y `thenUs` \ register2 ->
1398 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1399 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1401 code1 = registerCode register1 tmp1 asmVoid
1402 src1 = registerName register1 tmp1
1403 code2 = registerCode register2 tmp2 asmVoid
1404 src2 = registerName register2 tmp2
1405 code__2 = asmParThen [code1, code2] .
1406 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1408 returnUs (CondCode False cond code__2)
1412 condFltCode cond x (StDouble 0.0)
1413 = getRegister x `thenUs` \ register1 ->
1414 getNewRegNCG (registerRep register1)
1417 pk1 = registerRep register1
1418 code1 = registerCode register1 tmp1
1419 src1 = registerName register1 tmp1
1421 code__2 = asmParThen [code1 asmVoid] .
1422 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1424 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1425 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1429 returnUs (CondCode True (fix_FP_cond cond) code__2)
1431 condFltCode cond x y
1432 = getRegister x `thenUs` \ register1 ->
1433 getRegister y `thenUs` \ register2 ->
1434 getNewRegNCG (registerRep register1)
1436 getNewRegNCG (registerRep register2)
1439 pk1 = registerRep register1
1440 code1 = registerCode register1 tmp1
1441 src1 = registerName register1 tmp1
1443 code2 = registerCode register2 tmp2
1444 src2 = registerName register2 tmp2
1446 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1447 mkSeqInstrs [FUCOMPP,
1449 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1450 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1454 returnUs (CondCode True (fix_FP_cond cond) code__2)
1456 {- On the 486, the flags set by FP compare are the unsigned ones!
1457 (This looks like a HACK to me. WDP 96/03)
1460 fix_FP_cond :: Cond -> Cond
1462 fix_FP_cond GE = GEU
1465 fix_FP_cond LE = LEU
1466 fix_FP_cond any = any
1468 #endif {- i386_TARGET_ARCH -}
1469 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1470 #if sparc_TARGET_ARCH
1472 condIntCode cond x (StInt y)
1474 = getRegister x `thenUs` \ register ->
1475 getNewRegNCG IntRep `thenUs` \ tmp ->
1477 code = registerCode register tmp
1478 src1 = registerName register tmp
1479 src2 = ImmInt (fromInteger y)
1480 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1482 returnUs (CondCode False cond code__2)
1484 condIntCode cond x y
1485 = getRegister x `thenUs` \ register1 ->
1486 getRegister y `thenUs` \ register2 ->
1487 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1488 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1490 code1 = registerCode register1 tmp1 asmVoid
1491 src1 = registerName register1 tmp1
1492 code2 = registerCode register2 tmp2 asmVoid
1493 src2 = registerName register2 tmp2
1494 code__2 = asmParThen [code1, code2] .
1495 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1497 returnUs (CondCode False cond code__2)
1500 condFltCode cond x y
1501 = getRegister x `thenUs` \ register1 ->
1502 getRegister y `thenUs` \ register2 ->
1503 getNewRegNCG (registerRep register1)
1505 getNewRegNCG (registerRep register2)
1507 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1509 promote x = asmInstr (FxTOy F DF x tmp)
1511 pk1 = registerRep register1
1512 code1 = registerCode register1 tmp1
1513 src1 = registerName register1 tmp1
1515 pk2 = registerRep register2
1516 code2 = registerCode register2 tmp2
1517 src2 = registerName register2 tmp2
1521 asmParThen [code1 asmVoid, code2 asmVoid] .
1522 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1523 else if pk1 == FloatRep then
1524 asmParThen [code1 (promote src1), code2 asmVoid] .
1525 mkSeqInstr (FCMP True DF tmp src2)
1527 asmParThen [code1 asmVoid, code2 (promote src2)] .
1528 mkSeqInstr (FCMP True DF src1 tmp)
1530 returnUs (CondCode True cond code__2)
1532 #endif {- sparc_TARGET_ARCH -}
1535 %************************************************************************
1537 \subsection{Generating assignments}
1539 %************************************************************************
1541 Assignments are really at the heart of the whole code generation
1542 business. Almost all top-level nodes of any real importance are
1543 assignments, which correspond to loads, stores, or register transfers.
1544 If we're really lucky, some of the register transfers will go away,
1545 because we can use the destination register to complete the code
1546 generation for the right hand side. This only fails when the right
1547 hand side is forced into a fixed register (e.g. the result of a call).
1550 assignIntCode, assignFltCode
1551 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1553 #if alpha_TARGET_ARCH
1555 assignIntCode pk (StInd _ dst) src
1556 = getNewRegNCG IntRep `thenUs` \ tmp ->
1557 getAmode dst `thenUs` \ amode ->
1558 getRegister src `thenUs` \ register ->
1560 code1 = amodeCode amode asmVoid
1561 dst__2 = amodeAddr amode
1562 code2 = registerCode register tmp asmVoid
1563 src__2 = registerName register tmp
1564 sz = primRepToSize pk
1565 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1569 assignIntCode pk dst src
1570 = getRegister dst `thenUs` \ register1 ->
1571 getRegister src `thenUs` \ register2 ->
1573 dst__2 = registerName register1 zero
1574 code = registerCode register2 dst__2
1575 src__2 = registerName register2 dst__2
1576 code__2 = if isFixed register2
1577 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1582 #endif {- alpha_TARGET_ARCH -}
1583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1584 #if i386_TARGET_ARCH
1586 assignIntCode pk (StInd _ dst) src
1587 = getAmode dst `thenUs` \ amode ->
1588 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1590 code1 = amodeCode amode asmVoid
1591 dst__2 = amodeAddr amode
1592 code__2 = asmParThen [code1, codesrc asmVoid] .
1593 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1599 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1603 = returnUs (asmParThen [], OpImm imm_op, L)
1606 imm_op = case imm of Just x -> x
1609 = getRegister op `thenUs` \ register ->
1610 getNewRegNCG (registerRep register)
1613 code = registerCode register tmp
1614 reg = registerName register tmp
1615 pk = registerRep register
1616 sz = primRepToSize pk
1618 returnUs (code, OpReg reg, sz)
1620 assignIntCode pk dst (StInd _ src)
1621 = getNewRegNCG IntRep `thenUs` \ tmp ->
1622 getAmode src `thenUs` \ amode ->
1623 getRegister dst `thenUs` \ register ->
1625 code1 = amodeCode amode asmVoid
1626 src__2 = amodeAddr amode
1627 code2 = registerCode register tmp asmVoid
1628 dst__2 = registerName register tmp
1629 sz = primRepToSize pk
1630 code__2 = asmParThen [code1, code2] .
1631 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1635 assignIntCode pk dst src
1636 = getRegister dst `thenUs` \ register1 ->
1637 getRegister src `thenUs` \ register2 ->
1638 getNewRegNCG IntRep `thenUs` \ tmp ->
1640 dst__2 = registerName register1 tmp
1641 code = registerCode register2 dst__2
1642 src__2 = registerName register2 dst__2
1643 code__2 = if isFixed register2 && dst__2 /= src__2
1644 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1649 #endif {- i386_TARGET_ARCH -}
1650 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1651 #if sparc_TARGET_ARCH
1653 assignIntCode pk (StInd _ dst) src
1654 = getNewRegNCG IntRep `thenUs` \ tmp ->
1655 getAmode dst `thenUs` \ amode ->
1656 getRegister src `thenUs` \ register ->
1658 code1 = amodeCode amode asmVoid
1659 dst__2 = amodeAddr amode
1660 code2 = registerCode register tmp asmVoid
1661 src__2 = registerName register tmp
1662 sz = primRepToSize pk
1663 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1667 assignIntCode pk dst src
1668 = getRegister dst `thenUs` \ register1 ->
1669 getRegister src `thenUs` \ register2 ->
1671 dst__2 = registerName register1 g0
1672 code = registerCode register2 dst__2
1673 src__2 = registerName register2 dst__2
1674 code__2 = if isFixed register2
1675 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1680 #endif {- sparc_TARGET_ARCH -}
1683 % --------------------------------
1684 Floating-point assignments:
1685 % --------------------------------
1687 #if alpha_TARGET_ARCH
1689 assignFltCode pk (StInd _ dst) src
1690 = getNewRegNCG pk `thenUs` \ tmp ->
1691 getAmode dst `thenUs` \ amode ->
1692 getRegister src `thenUs` \ register ->
1694 code1 = amodeCode amode asmVoid
1695 dst__2 = amodeAddr amode
1696 code2 = registerCode register tmp asmVoid
1697 src__2 = registerName register tmp
1698 sz = primRepToSize pk
1699 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1703 assignFltCode pk dst src
1704 = getRegister dst `thenUs` \ register1 ->
1705 getRegister src `thenUs` \ register2 ->
1707 dst__2 = registerName register1 zero
1708 code = registerCode register2 dst__2
1709 src__2 = registerName register2 dst__2
1710 code__2 = if isFixed register2
1711 then code . mkSeqInstr (FMOV src__2 dst__2)
1716 #endif {- alpha_TARGET_ARCH -}
1717 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1718 #if i386_TARGET_ARCH
1720 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1721 = getNewRegNCG IntRep `thenUs` \ tmp ->
1722 getAmode src `thenUs` \ amodesrc ->
1723 getAmode dst `thenUs` \ amodedst ->
1724 --getRegister src `thenUs` \ register ->
1726 codesrc1 = amodeCode amodesrc asmVoid
1727 addrsrc1 = amodeAddr amodesrc
1728 codedst1 = amodeCode amodedst asmVoid
1729 addrdst1 = amodeAddr amodedst
1730 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1731 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1733 code__2 = asmParThen [codesrc1, codedst1] .
1734 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1735 MOV L (OpReg tmp) (OpAddr addrdst1)]
1738 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1739 MOV L (OpReg tmp) (OpAddr addrdst2)]
1744 assignFltCode pk (StInd _ dst) src
1745 = --getNewRegNCG pk `thenUs` \ tmp ->
1746 getAmode dst `thenUs` \ amode ->
1747 getRegister src `thenUs` \ register ->
1749 sz = primRepToSize pk
1750 dst__2 = amodeAddr amode
1752 code1 = amodeCode amode asmVoid
1753 code2 = registerCode register {-tmp-}st0 asmVoid
1755 --src__2= registerName register tmp
1756 pk__2 = registerRep register
1757 sz__2 = primRepToSize pk__2
1759 code__2 = asmParThen [code1, code2] .
1760 mkSeqInstr (FSTP sz (OpAddr dst__2))
1764 assignFltCode pk dst src
1765 = getRegister dst `thenUs` \ register1 ->
1766 getRegister src `thenUs` \ register2 ->
1767 --getNewRegNCG (registerRep register2)
1768 -- `thenUs` \ tmp ->
1770 sz = primRepToSize pk
1771 dst__2 = registerName register1 st0 --tmp
1773 code = registerCode register2 dst__2
1774 src__2 = registerName register2 dst__2
1780 #endif {- i386_TARGET_ARCH -}
1781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1782 #if sparc_TARGET_ARCH
1784 assignFltCode pk (StInd _ dst) src
1785 = getNewRegNCG pk `thenUs` \ tmp ->
1786 getAmode dst `thenUs` \ amode ->
1787 getRegister src `thenUs` \ register ->
1789 sz = primRepToSize pk
1790 dst__2 = amodeAddr amode
1792 code1 = amodeCode amode asmVoid
1793 code2 = registerCode register tmp asmVoid
1795 src__2 = registerName register tmp
1796 pk__2 = registerRep register
1797 sz__2 = primRepToSize pk__2
1799 code__2 = asmParThen [code1, code2] .
1801 mkSeqInstr (ST sz src__2 dst__2)
1803 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
1807 assignFltCode pk dst src
1808 = getRegister dst `thenUs` \ register1 ->
1809 getRegister src `thenUs` \ register2 ->
1810 getNewRegNCG (registerRep register2)
1813 sz = primRepToSize pk
1814 dst__2 = registerName register1 g0 -- must be Fixed
1816 reg__2 = if pk /= pk__2 then tmp else dst__2
1818 code = registerCode register2 reg__2
1819 src__2 = registerName register2 reg__2
1820 pk__2 = registerRep register2
1821 sz__2 = primRepToSize pk__2
1823 code__2 = if pk /= pk__2 then
1824 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1825 else if isFixed register2 then
1826 code . mkSeqInstr (FMOV sz src__2 dst__2)
1832 #endif {- sparc_TARGET_ARCH -}
1835 %************************************************************************
1837 \subsection{Generating an unconditional branch}
1839 %************************************************************************
1841 We accept two types of targets: an immediate CLabel or a tree that
1842 gets evaluated into a register. Any CLabels which are AsmTemporaries
1843 are assumed to be in the local block of code, close enough for a
1844 branch instruction. Other CLabels are assumed to be far away.
1846 (If applicable) Do not fill the delay slots here; you will confuse the
1850 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1852 #if alpha_TARGET_ARCH
1854 genJump (StCLbl lbl)
1855 | isAsmTemp lbl = returnInstr (BR target)
1856 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
1858 target = ImmCLbl lbl
1861 = getRegister tree `thenUs` \ register ->
1862 getNewRegNCG PtrRep `thenUs` \ tmp ->
1864 dst = registerName register pv
1865 code = registerCode register pv
1866 target = registerName register pv
1868 if isFixed register then
1869 returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
1871 returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
1873 #endif {- alpha_TARGET_ARCH -}
1874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1875 #if i386_TARGET_ARCH
1878 genJump (StCLbl lbl)
1879 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1880 | otherwise = returnInstrs [JMP (OpImm target)]
1882 target = ImmCLbl lbl
1885 genJump (StInd pk mem)
1886 = getAmode mem `thenUs` \ amode ->
1888 code = amodeCode amode
1889 target = amodeAddr amode
1891 returnSeq code [JMP (OpAddr target)]
1895 = returnInstr (JMP (OpImm target))
1898 = getRegister tree `thenUs` \ register ->
1899 getNewRegNCG PtrRep `thenUs` \ tmp ->
1901 code = registerCode register tmp
1902 target = registerName register tmp
1904 returnSeq code [JMP (OpReg target)]
1907 target = case imm of Just x -> x
1909 #endif {- i386_TARGET_ARCH -}
1910 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1911 #if sparc_TARGET_ARCH
1913 genJump (StCLbl lbl)
1914 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1915 | otherwise = returnInstrs [CALL target 0 True, NOP]
1917 target = ImmCLbl lbl
1920 = getRegister tree `thenUs` \ register ->
1921 getNewRegNCG PtrRep `thenUs` \ tmp ->
1923 code = registerCode register tmp
1924 target = registerName register tmp
1926 returnSeq code [JMP (AddrRegReg target g0), NOP]
1928 #endif {- sparc_TARGET_ARCH -}
1931 %************************************************************************
1933 \subsection{Conditional jumps}
1935 %************************************************************************
1937 Conditional jumps are always to local labels, so we can use branch
1938 instructions. We peek at the arguments to decide what kind of
1941 ALPHA: For comparisons with 0, we're laughing, because we can just do
1942 the desired conditional branch.
1944 I386: First, we have to ensure that the condition
1945 codes are set according to the supplied comparison operation.
1947 SPARC: First, we have to ensure that the condition codes are set
1948 according to the supplied comparison operation. We generate slightly
1949 different code for floating point comparisons, because a floating
1950 point operation cannot directly precede a @BF@. We assume the worst
1951 and fill that slot with a @NOP@.
1953 SPARC: Do not fill the delay slots here; you will confuse the register
1958 :: CLabel -- the branch target
1959 -> StixTree -- the condition on which to branch
1960 -> UniqSM InstrBlock
1962 #if alpha_TARGET_ARCH
1964 genCondJump lbl (StPrim op [x, StInt 0])
1965 = getRegister x `thenUs` \ register ->
1966 getNewRegNCG (registerRep register)
1969 code = registerCode register tmp
1970 value = registerName register tmp
1971 pk = registerRep register
1972 target = ImmCLbl lbl
1974 returnSeq code [BI (cmpOp op) value target]
1989 cmpOp WordGeOp = ALWAYS
1992 cmpOp WordLtOp = NEVER
1995 cmpOp AddrGeOp = ALWAYS
1998 cmpOp AddrLtOp = NEVER
2001 genCondJump lbl (StPrim op [x, StDouble 0.0])
2002 = getRegister x `thenUs` \ register ->
2003 getNewRegNCG (registerRep register)
2006 code = registerCode register tmp
2007 value = registerName register tmp
2008 pk = registerRep register
2009 target = ImmCLbl lbl
2011 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2013 cmpOp FloatGtOp = GT
2014 cmpOp FloatGeOp = GE
2015 cmpOp FloatEqOp = EQ
2016 cmpOp FloatNeOp = NE
2017 cmpOp FloatLtOp = LT
2018 cmpOp FloatLeOp = LE
2019 cmpOp DoubleGtOp = GT
2020 cmpOp DoubleGeOp = GE
2021 cmpOp DoubleEqOp = EQ
2022 cmpOp DoubleNeOp = NE
2023 cmpOp DoubleLtOp = LT
2024 cmpOp DoubleLeOp = LE
2026 genCondJump lbl (StPrim op [x, y])
2028 = trivialFCode pr instr x y `thenUs` \ register ->
2029 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2031 code = registerCode register tmp
2032 result = registerName register tmp
2033 target = ImmCLbl lbl
2035 returnUs (code . mkSeqInstr (BF cond result target))
2037 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2039 fltCmpOp op = case op of
2053 (instr, cond) = case op of
2054 FloatGtOp -> (FCMP TF LE, EQ)
2055 FloatGeOp -> (FCMP TF LT, EQ)
2056 FloatEqOp -> (FCMP TF EQ, NE)
2057 FloatNeOp -> (FCMP TF EQ, EQ)
2058 FloatLtOp -> (FCMP TF LT, NE)
2059 FloatLeOp -> (FCMP TF LE, NE)
2060 DoubleGtOp -> (FCMP TF LE, EQ)
2061 DoubleGeOp -> (FCMP TF LT, EQ)
2062 DoubleEqOp -> (FCMP TF EQ, NE)
2063 DoubleNeOp -> (FCMP TF EQ, EQ)
2064 DoubleLtOp -> (FCMP TF LT, NE)
2065 DoubleLeOp -> (FCMP TF LE, NE)
2067 genCondJump lbl (StPrim op [x, y])
2068 = trivialCode instr x y `thenUs` \ register ->
2069 getNewRegNCG IntRep `thenUs` \ tmp ->
2071 code = registerCode register tmp
2072 result = registerName register tmp
2073 target = ImmCLbl lbl
2075 returnUs (code . mkSeqInstr (BI cond result target))
2077 (instr, cond) = case op of
2078 CharGtOp -> (CMP LE, EQ)
2079 CharGeOp -> (CMP LT, EQ)
2080 CharEqOp -> (CMP EQ, NE)
2081 CharNeOp -> (CMP EQ, EQ)
2082 CharLtOp -> (CMP LT, NE)
2083 CharLeOp -> (CMP LE, NE)
2084 IntGtOp -> (CMP LE, EQ)
2085 IntGeOp -> (CMP LT, EQ)
2086 IntEqOp -> (CMP EQ, NE)
2087 IntNeOp -> (CMP EQ, EQ)
2088 IntLtOp -> (CMP LT, NE)
2089 IntLeOp -> (CMP LE, NE)
2090 WordGtOp -> (CMP ULE, EQ)
2091 WordGeOp -> (CMP ULT, EQ)
2092 WordEqOp -> (CMP EQ, NE)
2093 WordNeOp -> (CMP EQ, EQ)
2094 WordLtOp -> (CMP ULT, NE)
2095 WordLeOp -> (CMP ULE, NE)
2096 AddrGtOp -> (CMP ULE, EQ)
2097 AddrGeOp -> (CMP ULT, EQ)
2098 AddrEqOp -> (CMP EQ, NE)
2099 AddrNeOp -> (CMP EQ, EQ)
2100 AddrLtOp -> (CMP ULT, NE)
2101 AddrLeOp -> (CMP ULE, NE)
2103 #endif {- alpha_TARGET_ARCH -}
2104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2105 #if i386_TARGET_ARCH
2107 genCondJump lbl bool
2108 = getCondCode bool `thenUs` \ condition ->
2110 code = condCode condition
2111 cond = condName condition
2112 target = ImmCLbl lbl
2114 returnSeq code [JXX cond lbl]
2116 #endif {- i386_TARGET_ARCH -}
2117 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2118 #if sparc_TARGET_ARCH
2120 genCondJump lbl bool
2121 = getCondCode bool `thenUs` \ condition ->
2123 code = condCode condition
2124 cond = condName condition
2125 target = ImmCLbl lbl
2128 if condFloat condition then
2129 [NOP, BF cond False target, NOP]
2131 [BI cond False target, NOP]
2134 #endif {- sparc_TARGET_ARCH -}
2137 %************************************************************************
2139 \subsection{Generating C calls}
2141 %************************************************************************
2143 Now the biggest nightmare---calls. Most of the nastiness is buried in
2144 @get_arg@, which moves the arguments to the correct registers/stack
2145 locations. Apart from that, the code is easy.
2147 (If applicable) Do not fill the delay slots here; you will confuse the
2152 :: FAST_STRING -- function to call
2153 -> PrimRep -- type of the result
2154 -> [StixTree] -- arguments (of mixed type)
2155 -> UniqSM InstrBlock
2157 #if alpha_TARGET_ARCH
2159 genCCall fn kind args
2160 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2161 `thenUs` \ ((unused,_), argCode) ->
2163 nRegs = length allArgRegs - length unused
2164 code = asmParThen (map ($ asmVoid) argCode)
2167 LDA pv (AddrImm (ImmLab (uppPStr fn))),
2168 JSR ra (AddrReg pv) nRegs,
2169 LDGP gp (AddrReg ra)]
2171 ------------------------
2172 {- Try to get a value into a specific register (or registers) for
2173 a call. The first 6 arguments go into the appropriate
2174 argument register (separate registers for integer and floating
2175 point arguments, but used in lock-step), and the remaining
2176 arguments are dumped to the stack, beginning at 0(sp). Our
2177 first argument is a pair of the list of remaining argument
2178 registers to be assigned for this call and the next stack
2179 offset to use for overflowing arguments. This way,
2180 @get_Arg@ can be applied to all of a call's arguments using
2184 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2185 -> StixTree -- Current argument
2186 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2188 -- We have to use up all of our argument registers first...
2190 get_arg ((iDst,fDst):dsts, offset) arg
2191 = getRegister arg `thenUs` \ register ->
2193 reg = if isFloatingRep pk then fDst else iDst
2194 code = registerCode register reg
2195 src = registerName register reg
2196 pk = registerRep register
2199 if isFloatingRep pk then
2200 ((dsts, offset), if isFixed register then
2201 code . mkSeqInstr (FMOV src fDst)
2204 ((dsts, offset), if isFixed register then
2205 code . mkSeqInstr (OR src (RIReg src) iDst)
2208 -- Once we have run out of argument registers, we move to the
2211 get_arg ([], offset) arg
2212 = getRegister arg `thenUs` \ register ->
2213 getNewRegNCG (registerRep register)
2216 code = registerCode register tmp
2217 src = registerName register tmp
2218 pk = registerRep register
2219 sz = primRepToSize pk
2221 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2223 #endif {- alpha_TARGET_ARCH -}
2224 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2225 #if i386_TARGET_ARCH
2227 genCCall fn kind [StInt i]
2228 | fn == SLIT ("PerformGC_wrapper")
2229 = getUniqLabelNCG `thenUs` \ lbl ->
2231 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2232 MOV L (OpImm (ImmCLbl lbl))
2233 -- this is hardwired
2234 (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
2235 JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
2240 genCCall fn kind args
2241 = mapUs get_call_arg args `thenUs` \ argCode ->
2244 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
2245 MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2248 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2249 call = [CALL fn__2 -- ,
2250 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
2251 -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2254 returnSeq (code1 . code2) call
2256 -- function names that begin with '.' are assumed to be special
2257 -- internally generated names like '.mul,' which don't get an
2258 -- underscore prefix
2259 -- ToDo:needed (WDP 96/03) ???
2260 fn__2 = case (_HEAD_ fn) of
2261 '.' -> ImmLit (uppPStr fn)
2262 _ -> ImmLab (uppPStr fn)
2265 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2268 = get_op arg `thenUs` \ (code, op, sz) ->
2269 returnUs (code . mkSeqInstr (PUSH sz op))
2274 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2277 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2279 get_op (StInd pk mem)
2280 = getAmode mem `thenUs` \ amode ->
2282 code = amodeCode amode --asmVoid
2283 addr = amodeAddr amode
2284 sz = primRepToSize pk
2286 returnUs (code, OpAddr addr, sz)
2289 = getRegister op `thenUs` \ register ->
2290 getNewRegNCG (registerRep register)
2293 code = registerCode register tmp
2294 reg = registerName register tmp
2295 pk = registerRep register
2296 sz = primRepToSize pk
2298 returnUs (code, OpReg reg, sz)
2300 #endif {- i386_TARGET_ARCH -}
2301 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2302 #if sparc_TARGET_ARCH
2304 genCCall fn kind args
2305 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2306 `thenUs` \ ((unused,_), argCode) ->
2308 nRegs = length allArgRegs - length unused
2309 call = CALL fn__2 nRegs False
2310 code = asmParThen (map ($ asmVoid) argCode)
2312 returnSeq code [call, NOP]
2314 -- function names that begin with '.' are assumed to be special
2315 -- internally generated names like '.mul,' which don't get an
2316 -- underscore prefix
2317 -- ToDo:needed (WDP 96/03) ???
2318 fn__2 = case (_HEAD_ fn) of
2319 '.' -> ImmLit (uppPStr fn)
2320 _ -> ImmLab (uppPStr fn)
2322 ------------------------------------
2323 {- Try to get a value into a specific register (or registers) for
2324 a call. The SPARC calling convention is an absolute
2325 nightmare. The first 6x32 bits of arguments are mapped into
2326 %o0 through %o5, and the remaining arguments are dumped to the
2327 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2328 first argument is a pair of the list of remaining argument
2329 registers to be assigned for this call and the next stack
2330 offset to use for overflowing arguments. This way,
2331 @get_arg@ can be applied to all of a call's arguments using
2335 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2336 -> StixTree -- Current argument
2337 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2339 -- We have to use up all of our argument registers first...
2341 get_arg (dst:dsts, offset) arg
2342 = getRegister arg `thenUs` \ register ->
2343 getNewRegNCG (registerRep register)
2346 reg = if isFloatingRep pk then tmp else dst
2347 code = registerCode register reg
2348 src = registerName register reg
2349 pk = registerRep register
2351 returnUs (case pk of
2354 [] -> (([], offset + 1), code . mkSeqInstrs [
2355 -- conveniently put the second part in the right stack
2356 -- location, and load the first part into %o5
2357 ST DF src (spRel (offset - 1)),
2358 LD W (spRel (offset - 1)) dst])
2359 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2360 ST DF src (spRel (-2)),
2361 LD W (spRel (-2)) dst,
2362 LD W (spRel (-1)) dst__2])
2363 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2364 ST F src (spRel (-2)),
2365 LD W (spRel (-2)) dst])
2366 _ -> ((dsts, offset), if isFixed register then
2367 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2370 -- Once we have run out of argument registers, we move to the
2373 get_arg ([], offset) arg
2374 = getRegister arg `thenUs` \ register ->
2375 getNewRegNCG (registerRep register)
2378 code = registerCode register tmp
2379 src = registerName register tmp
2380 pk = registerRep register
2381 sz = primRepToSize pk
2382 words = if pk == DoubleRep then 2 else 1
2384 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2386 #endif {- sparc_TARGET_ARCH -}
2389 %************************************************************************
2391 \subsection{Support bits}
2393 %************************************************************************
2395 %************************************************************************
2397 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2399 %************************************************************************
2401 Turn those condition codes into integers now (when they appear on
2402 the right hand side of an assignment).
2404 (If applicable) Do not fill the delay slots here; you will confuse the
2408 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2410 #if alpha_TARGET_ARCH
2411 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2412 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2413 #endif {- alpha_TARGET_ARCH -}
2415 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2416 #if i386_TARGET_ARCH
2419 = condIntCode cond x y `thenUs` \ condition ->
2420 getNewRegNCG IntRep `thenUs` \ tmp ->
2421 --getRegister dst `thenUs` \ register ->
2423 --code2 = registerCode register tmp asmVoid
2424 --dst__2 = registerName register tmp
2425 code = condCode condition
2426 cond = condName condition
2427 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2428 code__2 dst = code . mkSeqInstrs [
2429 SETCC cond (OpReg tmp),
2430 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2431 MOV L (OpReg tmp) (OpReg dst)]
2433 returnUs (Any IntRep code__2)
2436 = getUniqLabelNCG `thenUs` \ lbl1 ->
2437 getUniqLabelNCG `thenUs` \ lbl2 ->
2438 condFltCode cond x y `thenUs` \ condition ->
2440 code = condCode condition
2441 cond = condName condition
2442 code__2 dst = code . mkSeqInstrs [
2444 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2447 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2450 returnUs (Any IntRep code__2)
2452 #endif {- i386_TARGET_ARCH -}
2453 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2454 #if sparc_TARGET_ARCH
2456 condIntReg EQ x (StInt 0)
2457 = getRegister x `thenUs` \ register ->
2458 getNewRegNCG IntRep `thenUs` \ tmp ->
2460 code = registerCode register tmp
2461 src = registerName register tmp
2462 code__2 dst = code . mkSeqInstrs [
2463 SUB False True g0 (RIReg src) g0,
2464 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2466 returnUs (Any IntRep code__2)
2469 = getRegister x `thenUs` \ register1 ->
2470 getRegister y `thenUs` \ register2 ->
2471 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2472 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2474 code1 = registerCode register1 tmp1 asmVoid
2475 src1 = registerName register1 tmp1
2476 code2 = registerCode register2 tmp2 asmVoid
2477 src2 = registerName register2 tmp2
2478 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2479 XOR False src1 (RIReg src2) dst,
2480 SUB False True g0 (RIReg dst) g0,
2481 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2483 returnUs (Any IntRep code__2)
2485 condIntReg NE x (StInt 0)
2486 = getRegister x `thenUs` \ register ->
2487 getNewRegNCG IntRep `thenUs` \ tmp ->
2489 code = registerCode register tmp
2490 src = registerName register tmp
2491 code__2 dst = code . mkSeqInstrs [
2492 SUB False True g0 (RIReg src) g0,
2493 ADD True False g0 (RIImm (ImmInt 0)) dst]
2495 returnUs (Any IntRep code__2)
2498 = getRegister x `thenUs` \ register1 ->
2499 getRegister y `thenUs` \ register2 ->
2500 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2501 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2503 code1 = registerCode register1 tmp1 asmVoid
2504 src1 = registerName register1 tmp1
2505 code2 = registerCode register2 tmp2 asmVoid
2506 src2 = registerName register2 tmp2
2507 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2508 XOR False src1 (RIReg src2) dst,
2509 SUB False True g0 (RIReg dst) g0,
2510 ADD True False g0 (RIImm (ImmInt 0)) dst]
2512 returnUs (Any IntRep code__2)
2515 = getUniqLabelNCG `thenUs` \ lbl1 ->
2516 getUniqLabelNCG `thenUs` \ lbl2 ->
2517 condIntCode cond x y `thenUs` \ condition ->
2519 code = condCode condition
2520 cond = condName condition
2521 code__2 dst = code . mkSeqInstrs [
2522 BI cond False (ImmCLbl lbl1), NOP,
2523 OR False g0 (RIImm (ImmInt 0)) dst,
2524 BI ALWAYS False (ImmCLbl lbl2), NOP,
2526 OR False g0 (RIImm (ImmInt 1)) dst,
2529 returnUs (Any IntRep code__2)
2532 = getUniqLabelNCG `thenUs` \ lbl1 ->
2533 getUniqLabelNCG `thenUs` \ lbl2 ->
2534 condFltCode cond x y `thenUs` \ condition ->
2536 code = condCode condition
2537 cond = condName condition
2538 code__2 dst = code . mkSeqInstrs [
2540 BF cond False (ImmCLbl lbl1), NOP,
2541 OR False g0 (RIImm (ImmInt 0)) dst,
2542 BI ALWAYS False (ImmCLbl lbl2), NOP,
2544 OR False g0 (RIImm (ImmInt 1)) dst,
2547 returnUs (Any IntRep code__2)
2549 #endif {- sparc_TARGET_ARCH -}
2552 %************************************************************************
2554 \subsubsection{@trivial*Code@: deal with trivial instructions}
2556 %************************************************************************
2558 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2559 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2560 for constants on the right hand side, because that's where the generic
2561 optimizer will have put them.
2563 Similarly, for unary instructions, we don't have to worry about
2564 matching an StInt as the argument, because genericOpt will already
2565 have handled the constant-folding.
2569 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2570 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2571 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2573 -> StixTree -> StixTree -- the two arguments
2578 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2579 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2581 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2582 (Size -> Operand -> Instr)
2583 -> (Size -> Operand -> Instr) {-reversed instr-}
2585 -> Instr {-reversed instr: pop-}
2587 -> StixTree -> StixTree -- the two arguments
2591 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2592 ,IF_ARCH_i386 ((Operand -> Instr)
2593 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2595 -> StixTree -- the one argument
2600 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2601 ,IF_ARCH_i386 (Instr
2602 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2604 -> StixTree -- the one argument
2607 #if alpha_TARGET_ARCH
2609 trivialCode instr x (StInt y)
2611 = getRegister x `thenUs` \ register ->
2612 getNewRegNCG IntRep `thenUs` \ tmp ->
2614 code = registerCode register tmp
2615 src1 = registerName register tmp
2616 src2 = ImmInt (fromInteger y)
2617 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2619 returnUs (Any IntRep code__2)
2621 trivialCode instr x y
2622 = getRegister x `thenUs` \ register1 ->
2623 getRegister y `thenUs` \ register2 ->
2624 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2625 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2627 code1 = registerCode register1 tmp1 asmVoid
2628 src1 = registerName register1 tmp1
2629 code2 = registerCode register2 tmp2 asmVoid
2630 src2 = registerName register2 tmp2
2631 code__2 dst = asmParThen [code1, code2] .
2632 mkSeqInstr (instr src1 (RIReg src2) dst)
2634 returnUs (Any IntRep code__2)
2637 trivialUCode instr x
2638 = getRegister x `thenUs` \ register ->
2639 getNewRegNCG IntRep `thenUs` \ tmp ->
2641 code = registerCode register tmp
2642 src = registerName register tmp
2643 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2645 returnUs (Any IntRep code__2)
2648 trivialFCode _ instr x y
2649 = getRegister x `thenUs` \ register1 ->
2650 getRegister y `thenUs` \ register2 ->
2651 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2652 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2654 code1 = registerCode register1 tmp1
2655 src1 = registerName register1 tmp1
2657 code2 = registerCode register2 tmp2
2658 src2 = registerName register2 tmp2
2660 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2661 mkSeqInstr (instr src1 src2 dst)
2663 returnUs (Any DoubleRep code__2)
2665 trivialUFCode _ instr x
2666 = getRegister x `thenUs` \ register ->
2667 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2669 code = registerCode register tmp
2670 src = registerName register tmp
2671 code__2 dst = code . mkSeqInstr (instr src dst)
2673 returnUs (Any DoubleRep code__2)
2675 #endif {- alpha_TARGET_ARCH -}
2676 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2677 #if i386_TARGET_ARCH
2679 trivialCode instr x y
2681 = getRegister x `thenUs` \ register1 ->
2682 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2684 fixedname = registerName register1 eax
2685 code__2 dst = let code1 = registerCode register1 dst
2686 src1 = registerName register1 dst
2688 if isFixed register1 && src1 /= dst
2689 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2690 instr (OpImm imm__2) (OpReg dst)]
2692 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2694 returnUs (Any IntRep code__2)
2697 imm__2 = case imm of Just x -> x
2699 trivialCode instr x y
2701 = getRegister y `thenUs` \ register1 ->
2702 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2704 fixedname = registerName register1 eax
2705 code__2 dst = let code1 = registerCode register1 dst
2706 src1 = registerName register1 dst
2708 if isFixed register1 && src1 /= dst
2709 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2710 instr (OpImm imm__2) (OpReg dst)]
2712 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2714 returnUs (Any IntRep code__2)
2717 imm__2 = case imm of Just x -> x
2719 trivialCode instr x (StInd pk mem)
2720 = getRegister x `thenUs` \ register ->
2721 --getNewRegNCG IntRep `thenUs` \ tmp ->
2722 getAmode mem `thenUs` \ amode ->
2724 fixedname = registerName register eax
2725 code2 = amodeCode amode asmVoid
2726 src2 = amodeAddr amode
2727 code__2 dst = let code1 = registerCode register dst asmVoid
2728 src1 = registerName register dst
2729 in asmParThen [code1, code2] .
2730 if isFixed register && src1 /= dst
2731 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2732 instr (OpAddr src2) (OpReg dst)]
2734 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2736 returnUs (Any pk code__2)
2738 trivialCode instr (StInd pk mem) y
2739 = getRegister y `thenUs` \ register ->
2740 --getNewRegNCG IntRep `thenUs` \ tmp ->
2741 getAmode mem `thenUs` \ amode ->
2743 fixedname = registerName register eax
2744 code2 = amodeCode amode asmVoid
2745 src2 = amodeAddr amode
2747 code1 = registerCode register dst asmVoid
2748 src1 = registerName register dst
2749 in asmParThen [code1, code2] .
2750 if isFixed register && src1 /= dst
2751 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2752 instr (OpAddr src2) (OpReg dst)]
2754 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2756 returnUs (Any pk code__2)
2758 trivialCode instr x y
2759 = getRegister x `thenUs` \ register1 ->
2760 getRegister y `thenUs` \ register2 ->
2761 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2762 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2764 fixedname = registerName register1 eax
2765 code2 = registerCode register2 tmp2 asmVoid
2766 src2 = registerName register2 tmp2
2768 code1 = registerCode register1 dst asmVoid
2769 src1 = registerName register1 dst
2770 in asmParThen [code1, code2] .
2771 if isFixed register1 && src1 /= dst
2772 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2773 instr (OpReg src2) (OpReg dst)]
2775 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2777 returnUs (Any IntRep code__2)
2780 trivialUCode instr x
2781 = getRegister x `thenUs` \ register ->
2782 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2784 -- fixedname = registerName register eax
2786 code = registerCode register dst
2787 src = registerName register dst
2788 in code . if isFixed register && dst /= src
2789 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2791 else mkSeqInstr (instr (OpReg src))
2793 returnUs (Any IntRep code__2)
2796 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2797 = getRegister y `thenUs` \ register2 ->
2798 --getNewRegNCG (registerRep register2)
2799 -- `thenUs` \ tmp2 ->
2800 getAmode mem `thenUs` \ amode ->
2802 code1 = amodeCode amode
2803 src1 = amodeAddr amode
2806 code2 = registerCode register2 dst
2807 src2 = registerName register2 dst
2808 in asmParThen [code1 asmVoid,code2 asmVoid] .
2809 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2811 returnUs (Any pk code__2)
2813 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2814 = getRegister x `thenUs` \ register1 ->
2815 --getNewRegNCG (registerRep register1)
2816 -- `thenUs` \ tmp1 ->
2817 getAmode mem `thenUs` \ amode ->
2819 code2 = amodeCode amode
2820 src2 = amodeAddr amode
2823 code1 = registerCode register1 dst
2824 src1 = registerName register1 dst
2825 in asmParThen [code2 asmVoid,code1 asmVoid] .
2826 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2828 returnUs (Any pk code__2)
2830 trivialFCode pk _ _ _ instrpr x y
2831 = getRegister x `thenUs` \ register1 ->
2832 getRegister y `thenUs` \ register2 ->
2833 --getNewRegNCG (registerRep register1)
2834 -- `thenUs` \ tmp1 ->
2835 --getNewRegNCG (registerRep register2)
2836 -- `thenUs` \ tmp2 ->
2837 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2839 pk1 = registerRep register1
2840 code1 = registerCode register1 st0 --tmp1
2841 src1 = registerName register1 st0 --tmp1
2843 pk2 = registerRep register2
2846 code2 = registerCode register2 dst
2847 src2 = registerName register2 dst
2848 in asmParThen [code1 asmVoid, code2 asmVoid] .
2851 returnUs (Any pk1 code__2)
2854 trivialUFCode pk instr (StInd pk' mem)
2855 = getAmode mem `thenUs` \ amode ->
2857 code = amodeCode amode
2858 src = amodeAddr amode
2859 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2862 returnUs (Any pk code__2)
2864 trivialUFCode pk instr x
2865 = getRegister x `thenUs` \ register ->
2866 --getNewRegNCG pk `thenUs` \ tmp ->
2869 code = registerCode register dst
2870 src = registerName register dst
2871 in code . mkSeqInstrs [instr]
2873 returnUs (Any pk code__2)
2875 #endif {- i386_TARGET_ARCH -}
2876 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2877 #if sparc_TARGET_ARCH
2879 trivialCode instr x (StInt y)
2881 = getRegister x `thenUs` \ register ->
2882 getNewRegNCG IntRep `thenUs` \ tmp ->
2884 code = registerCode register tmp
2885 src1 = registerName register tmp
2886 src2 = ImmInt (fromInteger y)
2887 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2889 returnUs (Any IntRep code__2)
2891 trivialCode instr x y
2892 = getRegister x `thenUs` \ register1 ->
2893 getRegister y `thenUs` \ register2 ->
2894 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2895 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2897 code1 = registerCode register1 tmp1 asmVoid
2898 src1 = registerName register1 tmp1
2899 code2 = registerCode register2 tmp2 asmVoid
2900 src2 = registerName register2 tmp2
2901 code__2 dst = asmParThen [code1, code2] .
2902 mkSeqInstr (instr src1 (RIReg src2) dst)
2904 returnUs (Any IntRep code__2)
2907 trivialFCode pk instr x y
2908 = getRegister x `thenUs` \ register1 ->
2909 getRegister y `thenUs` \ register2 ->
2910 getNewRegNCG (registerRep register1)
2912 getNewRegNCG (registerRep register2)
2914 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2916 promote x = asmInstr (FxTOy F DF x tmp)
2918 pk1 = registerRep register1
2919 code1 = registerCode register1 tmp1
2920 src1 = registerName register1 tmp1
2922 pk2 = registerRep register2
2923 code2 = registerCode register2 tmp2
2924 src2 = registerName register2 tmp2
2928 asmParThen [code1 asmVoid, code2 asmVoid] .
2929 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2930 else if pk1 == FloatRep then
2931 asmParThen [code1 (promote src1), code2 asmVoid] .
2932 mkSeqInstr (instr DF tmp src2 dst)
2934 asmParThen [code1 asmVoid, code2 (promote src2)] .
2935 mkSeqInstr (instr DF src1 tmp dst)
2937 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2940 trivialUCode instr x
2941 = getRegister x `thenUs` \ register ->
2942 getNewRegNCG IntRep `thenUs` \ tmp ->
2944 code = registerCode register tmp
2945 src = registerName register tmp
2946 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2948 returnUs (Any IntRep code__2)
2951 trivialUFCode pk instr x
2952 = getRegister x `thenUs` \ register ->
2953 getNewRegNCG pk `thenUs` \ tmp ->
2955 code = registerCode register tmp
2956 src = registerName register tmp
2957 code__2 dst = code . mkSeqInstr (instr src dst)
2959 returnUs (Any pk code__2)
2961 #endif {- sparc_TARGET_ARCH -}
2964 %************************************************************************
2966 \subsubsection{Coercing to/from integer/floating-point...}
2968 %************************************************************************
2970 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2971 to be generated. Here we just change the type on the Register passed
2972 on up. The code is machine-independent.
2974 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2975 conversions. We have to store temporaries in memory to move
2976 between the integer and the floating point register sets.
2979 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2980 coerceFltCode :: StixTree -> UniqSM Register
2982 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
2983 coerceFP2Int :: StixTree -> UniqSM Register
2986 = getRegister x `thenUs` \ register ->
2989 Fixed _ reg code -> Fixed pk reg code
2990 Any _ code -> Any pk code
2995 = getRegister x `thenUs` \ register ->
2998 Fixed _ reg code -> Fixed DoubleRep reg code
2999 Any _ code -> Any DoubleRep code
3004 #if alpha_TARGET_ARCH
3007 = getRegister x `thenUs` \ register ->
3008 getNewRegNCG IntRep `thenUs` \ reg ->
3010 code = registerCode register reg
3011 src = registerName register reg
3013 code__2 dst = code . mkSeqInstrs [
3015 LD TF dst (spRel 0),
3018 returnUs (Any DoubleRep code__2)
3022 = getRegister x `thenUs` \ register ->
3023 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3025 code = registerCode register tmp
3026 src = registerName register tmp
3028 code__2 dst = code . mkSeqInstrs [
3030 ST TF tmp (spRel 0),
3033 returnUs (Any IntRep code__2)
3035 #endif {- alpha_TARGET_ARCH -}
3036 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3037 #if i386_TARGET_ARCH
3040 = getRegister x `thenUs` \ register ->
3041 getNewRegNCG IntRep `thenUs` \ reg ->
3043 code = registerCode register reg
3044 src = registerName register reg
3046 code__2 dst = code . mkSeqInstrs [
3047 -- to fix: should spill instead of using R1
3048 MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
3049 FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3051 returnUs (Any pk code__2)
3055 = getRegister x `thenUs` \ register ->
3056 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3058 code = registerCode register tmp
3059 src = registerName register tmp
3060 pk = registerRep register
3063 in code . mkSeqInstrs [
3065 FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
3066 MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3068 returnUs (Any IntRep code__2)
3070 #endif {- i386_TARGET_ARCH -}
3071 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3072 #if sparc_TARGET_ARCH
3075 = getRegister x `thenUs` \ register ->
3076 getNewRegNCG IntRep `thenUs` \ reg ->
3078 code = registerCode register reg
3079 src = registerName register reg
3081 code__2 dst = code . mkSeqInstrs [
3082 ST W src (spRel (-2)),
3083 LD W (spRel (-2)) dst,
3084 FxTOy W (primRepToSize pk) dst dst]
3086 returnUs (Any pk code__2)
3090 = getRegister x `thenUs` \ register ->
3091 getNewRegNCG IntRep `thenUs` \ reg ->
3092 getNewRegNCG FloatRep `thenUs` \ tmp ->
3094 code = registerCode register reg
3095 src = registerName register reg
3096 pk = registerRep register
3098 code__2 dst = code . mkSeqInstrs [
3099 FxTOy (primRepToSize pk) W src tmp,
3100 ST W tmp (spRel (-2)),
3101 LD W (spRel (-2)) dst]
3103 returnUs (Any IntRep code__2)
3105 #endif {- sparc_TARGET_ARCH -}
3108 %************************************************************************
3110 \subsubsection{Coercing integer to @Char@...}
3112 %************************************************************************
3114 Integer to character conversion. Where applicable, we try to do this
3115 in one step if the original object is in memory.
3118 chrCode :: StixTree -> UniqSM Register
3120 #if alpha_TARGET_ARCH
3123 = getRegister x `thenUs` \ register ->
3124 getNewRegNCG IntRep `thenUs` \ reg ->
3126 code = registerCode register reg
3127 src = registerName register reg
3128 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3130 returnUs (Any IntRep code__2)
3132 #endif {- alpha_TARGET_ARCH -}
3133 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3134 #if i386_TARGET_ARCH
3137 = getRegister x `thenUs` \ register ->
3138 --getNewRegNCG IntRep `thenUs` \ reg ->
3140 fixedname = registerName register eax
3142 code = registerCode register dst
3143 src = registerName register dst
3145 if isFixed register && src /= dst
3146 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3147 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3148 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3150 returnUs (Any IntRep code__2)
3152 #endif {- i386_TARGET_ARCH -}
3153 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3154 #if sparc_TARGET_ARCH
3156 chrCode (StInd pk mem)
3157 = getAmode mem `thenUs` \ amode ->
3159 code = amodeCode amode
3160 src = amodeAddr amode
3161 src_off = addrOffset src 3
3162 src__2 = case src_off of Just x -> x
3163 code__2 dst = if maybeToBool src_off then
3164 code . mkSeqInstr (LD BU src__2 dst)
3166 code . mkSeqInstrs [
3167 LD (primRepToSize pk) src dst,
3168 AND False dst (RIImm (ImmInt 255)) dst]
3170 returnUs (Any pk code__2)
3173 = getRegister x `thenUs` \ register ->
3174 getNewRegNCG IntRep `thenUs` \ reg ->
3176 code = registerCode register reg
3177 src = registerName register reg
3178 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3180 returnUs (Any IntRep code__2)
3182 #endif {- sparc_TARGET_ARCH -}
3185 %************************************************************************
3187 \subsubsection{Absolute value on integers}
3189 %************************************************************************
3191 Absolute value on integers, mostly for gmp size check macros. Again,
3192 the argument cannot be an StInt, because genericOpt already folded
3195 If applicable, do not fill the delay slots here; you will confuse the
3199 absIntCode :: StixTree -> UniqSM Register
3201 #if alpha_TARGET_ARCH
3202 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3203 #endif {- alpha_TARGET_ARCH -}
3205 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3206 #if i386_TARGET_ARCH
3209 = getRegister x `thenUs` \ register ->
3210 --getNewRegNCG IntRep `thenUs` \ reg ->
3211 getUniqLabelNCG `thenUs` \ lbl ->
3213 code__2 dst = let code = registerCode register dst
3214 src = registerName register dst
3215 in code . if isFixed register && dst /= src
3216 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3217 TEST L (OpReg dst) (OpReg dst),
3221 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3226 returnUs (Any IntRep code__2)
3228 #endif {- i386_TARGET_ARCH -}
3229 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3230 #if sparc_TARGET_ARCH
3233 = getRegister x `thenUs` \ register ->
3234 getNewRegNCG IntRep `thenUs` \ reg ->
3235 getUniqLabelNCG `thenUs` \ lbl ->
3237 code = registerCode register reg
3238 src = registerName register reg
3239 code__2 dst = code . mkSeqInstrs [
3240 SUB False True g0 (RIReg src) dst,
3241 BI GE False (ImmCLbl lbl), NOP,
3242 OR False g0 (RIReg src) dst,
3245 returnUs (Any IntRep code__2)
3247 #endif {- sparc_TARGET_ARCH -}