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 module MachCode ( stmt2Instrs, asmVoid, InstrList ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
20 import AbsCSyn ( MagicId )
21 import AbsCUtils ( magicIdPrimRep )
22 import CLabel ( isAsmTemp, CLabel )
23 import Maybes ( maybeToBool, expectJust )
24 import OrdList -- quite a bit of it
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..), showPrimOp )
27 import Stix ( getUniqLabelNCG, StixTree(..),
28 StixReg(..), CodeSegment(..)
30 import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
36 Code extractor for an entire stix tree---stix statement level.
39 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
41 stmt2Instrs stmt = case stmt of
42 StComment s -> returnInstr (COMMENT s)
43 StSegment seg -> returnInstr (SEGMENT seg)
44 StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
45 StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
46 StLabel lab -> returnInstr (LABEL lab)
48 StJump arg -> genJump arg
49 StCondJump lab arg -> genCondJump lab arg
50 StCall fn VoidRep args -> genCCall fn VoidRep args
53 | isFloatingRep pk -> assignFltCode pk dst src
54 | otherwise -> assignIntCode pk dst src
57 -- When falling through on the Alpha, we still have to load pv
58 -- with the address of the next routine, so that it can load gp.
59 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
63 -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
64 returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
65 (foldr1 (.) codes xs))
67 getData :: StixTree -> UniqSM (InstrBlock, Imm)
69 getData (StInt i) = returnUs (id, ImmInteger i)
70 getData (StDouble d) = returnUs (id, dblImmLit d)
71 getData (StLitLbl s) = returnUs (id, ImmLab s)
72 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
73 getData (StCLbl l) = returnUs (id, ImmCLbl l)
74 getData (StString s) =
75 getUniqLabelNCG `thenUs` \ lbl ->
76 returnUs (mkSeqInstrs [LABEL lbl,
77 ASCII True (_UNPK_ s)],
81 %************************************************************************
83 \subsection{General things for putting together code sequences}
85 %************************************************************************
88 type InstrList = OrdList Instr
89 type InstrBlock = InstrList -> InstrList
94 asmInstr :: Instr -> InstrList
95 asmInstr i = mkUnitList i
97 asmSeq :: [Instr] -> InstrList
98 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
100 asmParThen :: [InstrList] -> InstrBlock
101 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
103 returnInstr :: Instr -> UniqSM InstrBlock
104 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
106 returnInstrs :: [Instr] -> UniqSM InstrBlock
107 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
109 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
110 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
112 mkSeqInstr :: Instr -> InstrBlock
113 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
115 mkSeqInstrs :: [Instr] -> InstrBlock
116 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
120 mangleIndexTree :: StixTree -> StixTree
122 mangleIndexTree (StIndex pk base (StInt i))
123 = StPrim IntAddOp [base, off]
125 off = StInt (i * sizeOf pk)
127 #ifndef i386_TARGET_ARCH
128 mangleIndexTree (StIndex pk base off)
129 = StPrim IntAddOp [base,
135 ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
136 StPrim SllOp [off, StInt s]
139 shift DoubleRep = 3::Integer
140 shift _ = IF_ARCH_alpha(3,2)
142 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
143 -- that do include the size of the primitive kind we're addressing. When StIndex
144 -- is expanded to actual code, the index (in units) is by the above code approp.
145 -- shifted to get the no. of bytes. Since Address amodes do contain size info
146 -- explicitly, we disable the shifting for x86s.
147 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
153 maybeImm :: StixTree -> Maybe Imm
155 maybeImm (StLitLbl s) = Just (ImmLab s)
156 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
157 maybeImm (StCLbl l) = Just (ImmCLbl l)
160 | i >= toInteger minInt && i <= toInteger maxInt
161 = Just (ImmInt (fromInteger i))
163 = Just (ImmInteger i)
168 %************************************************************************
170 \subsection{The @Register@ type}
172 %************************************************************************
174 @Register@s passed up the tree. If the stix code forces the register
175 to live in a pre-decided machine register, it comes out as @Fixed@;
176 otherwise, it comes out as @Any@, and the parent can decide which
177 register to put it in.
181 = Fixed PrimRep Reg InstrBlock
182 | Any PrimRep (Reg -> InstrBlock)
184 registerCode :: Register -> Reg -> InstrBlock
185 registerCode (Fixed _ _ code) reg = code
186 registerCode (Any _ code) reg = code reg
188 registerName :: Register -> Reg -> Reg
189 registerName (Fixed _ reg _) _ = reg
190 registerName (Any _ _) reg = reg
192 registerRep :: Register -> PrimRep
193 registerRep (Fixed pk _ _) = pk
194 registerRep (Any pk _) = pk
196 isFixed :: Register -> Bool
197 isFixed (Fixed _ _ _) = True
198 isFixed (Any _ _) = False
201 Generate code to get a subtree into a @Register@:
203 getRegister :: StixTree -> UniqSM Register
205 getRegister (StReg (StixMagicId stgreg))
206 = case (magicIdRegMaybe stgreg) of
207 Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
210 getRegister (StReg (StixTemp u pk))
211 = returnUs (Fixed pk (UnmappedReg u pk) id)
213 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
215 getRegister (StCall fn kind args)
216 = genCCall fn kind args `thenUs` \ call ->
217 returnUs (Fixed kind reg call)
219 reg = if isFloatingRep kind
220 then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
221 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
223 getRegister (StString s)
224 = getUniqLabelNCG `thenUs` \ lbl ->
226 imm_lbl = ImmCLbl lbl
228 code dst = mkSeqInstrs [
231 ASCII True (_UNPK_ s),
233 #if alpha_TARGET_ARCH
234 LDA dst (AddrImm imm_lbl)
237 MOV L (OpImm imm_lbl) (OpReg dst)
239 #if sparc_TARGET_ARCH
240 SETHI (HI imm_lbl) dst,
241 OR False dst (RIImm (LO imm_lbl)) dst
245 returnUs (Any PtrRep code)
247 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
248 = getUniqLabelNCG `thenUs` \ lbl ->
250 imm_lbl = ImmCLbl lbl
252 code dst = mkSeqInstrs [
255 ASCII False (init xs),
257 #if alpha_TARGET_ARCH
258 LDA dst (AddrImm imm_lbl)
261 MOV L (OpImm imm_lbl) (OpReg dst)
263 #if sparc_TARGET_ARCH
264 SETHI (HI imm_lbl) dst,
265 OR False dst (RIImm (LO imm_lbl)) dst
269 returnUs (Any PtrRep code)
271 xs = _UNPK_ (_TAIL_ s)
273 -- end of machine-"independent" bit; here we go on the rest...
275 #if alpha_TARGET_ARCH
277 getRegister (StDouble d)
278 = getUniqLabelNCG `thenUs` \ lbl ->
279 getNewRegNCG PtrRep `thenUs` \ tmp ->
280 let code dst = mkSeqInstrs [
283 DATA TF [ImmLab (rational d)],
285 LDA tmp (AddrImm (ImmCLbl lbl)),
286 LD TF dst (AddrReg tmp)]
288 returnUs (Any DoubleRep code)
290 getRegister (StPrim primop [x]) -- unary PrimOps
292 IntNegOp -> trivialUCode (NEG Q False) x
293 IntAbsOp -> trivialUCode (ABS Q) x
295 NotOp -> trivialUCode NOT x
297 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
298 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
300 OrdOp -> coerceIntCode IntRep x
303 Float2IntOp -> coerceFP2Int x
304 Int2FloatOp -> coerceInt2FP pr x
305 Double2IntOp -> coerceFP2Int x
306 Int2DoubleOp -> coerceInt2FP pr x
308 Double2FloatOp -> coerceFltCode x
309 Float2DoubleOp -> coerceFltCode x
311 other_op -> getRegister (StCall fn DoubleRep [x])
313 fn = case other_op of
314 FloatExpOp -> SLIT("exp")
315 FloatLogOp -> SLIT("log")
316 FloatSqrtOp -> SLIT("sqrt")
317 FloatSinOp -> SLIT("sin")
318 FloatCosOp -> SLIT("cos")
319 FloatTanOp -> SLIT("tan")
320 FloatAsinOp -> SLIT("asin")
321 FloatAcosOp -> SLIT("acos")
322 FloatAtanOp -> SLIT("atan")
323 FloatSinhOp -> SLIT("sinh")
324 FloatCoshOp -> SLIT("cosh")
325 FloatTanhOp -> SLIT("tanh")
326 DoubleExpOp -> SLIT("exp")
327 DoubleLogOp -> SLIT("log")
328 DoubleSqrtOp -> SLIT("sqrt")
329 DoubleSinOp -> SLIT("sin")
330 DoubleCosOp -> SLIT("cos")
331 DoubleTanOp -> SLIT("tan")
332 DoubleAsinOp -> SLIT("asin")
333 DoubleAcosOp -> SLIT("acos")
334 DoubleAtanOp -> SLIT("atan")
335 DoubleSinhOp -> SLIT("sinh")
336 DoubleCoshOp -> SLIT("cosh")
337 DoubleTanhOp -> SLIT("tanh")
339 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
341 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
343 CharGtOp -> trivialCode (CMP LTT) y x
344 CharGeOp -> trivialCode (CMP LE) y x
345 CharEqOp -> trivialCode (CMP EQQ) x y
346 CharNeOp -> int_NE_code x y
347 CharLtOp -> trivialCode (CMP LTT) x y
348 CharLeOp -> trivialCode (CMP LE) x y
350 IntGtOp -> trivialCode (CMP LTT) y x
351 IntGeOp -> trivialCode (CMP LE) y x
352 IntEqOp -> trivialCode (CMP EQQ) x y
353 IntNeOp -> int_NE_code x y
354 IntLtOp -> trivialCode (CMP LTT) x y
355 IntLeOp -> trivialCode (CMP LE) x y
357 WordGtOp -> trivialCode (CMP ULT) y x
358 WordGeOp -> trivialCode (CMP ULE) x y
359 WordEqOp -> trivialCode (CMP EQQ) x y
360 WordNeOp -> int_NE_code x y
361 WordLtOp -> trivialCode (CMP ULT) x y
362 WordLeOp -> trivialCode (CMP ULE) x y
364 AddrGtOp -> trivialCode (CMP ULT) y x
365 AddrGeOp -> trivialCode (CMP ULE) y x
366 AddrEqOp -> trivialCode (CMP EQQ) x y
367 AddrNeOp -> int_NE_code x y
368 AddrLtOp -> trivialCode (CMP ULT) x y
369 AddrLeOp -> trivialCode (CMP ULE) x y
371 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
372 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
373 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
374 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
375 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
376 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
378 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
379 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
380 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
381 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
382 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
383 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
385 IntAddOp -> trivialCode (ADD Q False) x y
386 IntSubOp -> trivialCode (SUB Q False) x y
387 IntMulOp -> trivialCode (MUL Q False) x y
388 IntQuotOp -> trivialCode (DIV Q False) x y
389 IntRemOp -> trivialCode (REM Q False) x y
391 WordQuotOp -> trivialCode (DIV Q True) x y
392 WordRemOp -> trivialCode (REM Q True) x y
394 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
395 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
396 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
397 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
399 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
400 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
401 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
402 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
404 AndOp -> trivialCode AND x y
405 OrOp -> trivialCode OR x y
406 XorOp -> trivialCode XOR x y
407 SllOp -> trivialCode SLL x y
408 SraOp -> trivialCode SRA x y
409 SrlOp -> trivialCode SRL x y
411 ISllOp -> panic "AlphaGen:isll"
412 ISraOp -> panic "AlphaGen:isra"
413 ISrlOp -> panic "AlphaGen:isrl"
415 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
416 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
418 {- ------------------------------------------------------------
419 Some bizarre special code for getting condition codes into
420 registers. Integer non-equality is a test for equality
421 followed by an XOR with 1. (Integer comparisons always set
422 the result register to 0 or 1.) Floating point comparisons of
423 any kind leave the result in a floating point register, so we
424 need to wrangle an integer register out of things.
426 int_NE_code :: StixTree -> StixTree -> UniqSM Register
429 = trivialCode (CMP EQQ) x y `thenUs` \ register ->
430 getNewRegNCG IntRep `thenUs` \ tmp ->
432 code = registerCode register tmp
433 src = registerName register tmp
434 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
436 returnUs (Any IntRep code__2)
438 {- ------------------------------------------------------------
439 Comments for int_NE_code also apply to cmpF_code
442 :: (Reg -> Reg -> Reg -> Instr)
444 -> StixTree -> StixTree
447 cmpF_code instr cond x y
448 = trivialFCode pr instr x y `thenUs` \ register ->
449 getNewRegNCG DoubleRep `thenUs` \ tmp ->
450 getUniqLabelNCG `thenUs` \ lbl ->
452 code = registerCode register tmp
453 result = registerName register tmp
455 code__2 dst = code . mkSeqInstrs [
456 OR zeroh (RIImm (ImmInt 1)) dst,
457 BF cond result (ImmCLbl lbl),
458 OR zeroh (RIReg zeroh) dst,
461 returnUs (Any IntRep code__2)
463 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
464 ------------------------------------------------------------
466 getRegister (StInd pk mem)
467 = getAmode mem `thenUs` \ amode ->
469 code = amodeCode amode
470 src = amodeAddr amode
471 size = primRepToSize pk
472 code__2 dst = code . mkSeqInstr (LD size dst src)
474 returnUs (Any pk code__2)
476 getRegister (StInt i)
479 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
481 returnUs (Any IntRep code)
484 code dst = mkSeqInstr (LDI Q dst src)
486 returnUs (Any IntRep code)
488 src = ImmInt (fromInteger i)
493 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
495 returnUs (Any PtrRep code)
498 imm__2 = case imm of Just x -> x
500 #endif {- alpha_TARGET_ARCH -}
501 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
504 getRegister (StDouble 0.0)
506 code dst = mkSeqInstrs [FLDZ]
508 returnUs (Any DoubleRep code)
510 getRegister (StDouble 1.0)
512 code dst = mkSeqInstrs [FLD1]
514 returnUs (Any DoubleRep code)
516 getRegister (StDouble d)
517 = getUniqLabelNCG `thenUs` \ lbl ->
518 --getNewRegNCG PtrRep `thenUs` \ tmp ->
519 let code dst = mkSeqInstrs [
522 DATA DF [dblImmLit d],
524 FLD DF (OpImm (ImmCLbl lbl))
527 returnUs (Any DoubleRep code)
529 getRegister (StPrim primop [x]) -- unary PrimOps
531 IntNegOp -> trivialUCode (NEGI L) x
532 IntAbsOp -> absIntCode x
534 NotOp -> trivialUCode (NOT L) x
536 FloatNegOp -> trivialUFCode FloatRep FCHS x
537 FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
538 DoubleNegOp -> trivialUFCode DoubleRep FCHS x
540 DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
542 OrdOp -> coerceIntCode IntRep x
545 Float2IntOp -> coerceFP2Int x
546 Int2FloatOp -> coerceInt2FP FloatRep x
547 Double2IntOp -> coerceFP2Int x
548 Int2DoubleOp -> coerceInt2FP DoubleRep x
550 Double2FloatOp -> coerceFltCode x
551 Float2DoubleOp -> coerceFltCode x
555 fixed_x = if is_float_op -- promote to double
556 then StPrim Float2DoubleOp [x]
559 getRegister (StCall fn DoubleRep [x])
563 FloatExpOp -> (True, SLIT("exp"))
564 FloatLogOp -> (True, SLIT("log"))
566 FloatSinOp -> (True, SLIT("sin"))
567 FloatCosOp -> (True, SLIT("cos"))
568 FloatTanOp -> (True, SLIT("tan"))
570 FloatAsinOp -> (True, SLIT("asin"))
571 FloatAcosOp -> (True, SLIT("acos"))
572 FloatAtanOp -> (True, SLIT("atan"))
574 FloatSinhOp -> (True, SLIT("sinh"))
575 FloatCoshOp -> (True, SLIT("cosh"))
576 FloatTanhOp -> (True, SLIT("tanh"))
578 DoubleExpOp -> (False, SLIT("exp"))
579 DoubleLogOp -> (False, SLIT("log"))
581 DoubleSinOp -> (False, SLIT("sin"))
582 DoubleCosOp -> (False, SLIT("cos"))
583 DoubleTanOp -> (False, SLIT("tan"))
585 DoubleAsinOp -> (False, SLIT("asin"))
586 DoubleAcosOp -> (False, SLIT("acos"))
587 DoubleAtanOp -> (False, SLIT("atan"))
589 DoubleSinhOp -> (False, SLIT("sinh"))
590 DoubleCoshOp -> (False, SLIT("cosh"))
591 DoubleTanhOp -> (False, SLIT("tanh"))
593 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
595 CharGtOp -> condIntReg GTT x y
596 CharGeOp -> condIntReg GE x y
597 CharEqOp -> condIntReg EQQ x y
598 CharNeOp -> condIntReg NE x y
599 CharLtOp -> condIntReg LTT x y
600 CharLeOp -> condIntReg LE x y
602 IntGtOp -> condIntReg GTT x y
603 IntGeOp -> condIntReg GE x y
604 IntEqOp -> condIntReg EQQ x y
605 IntNeOp -> condIntReg NE x y
606 IntLtOp -> condIntReg LTT x y
607 IntLeOp -> condIntReg LE x y
609 WordGtOp -> condIntReg GU x y
610 WordGeOp -> condIntReg GEU x y
611 WordEqOp -> condIntReg EQQ x y
612 WordNeOp -> condIntReg NE x y
613 WordLtOp -> condIntReg LU x y
614 WordLeOp -> condIntReg LEU x y
616 AddrGtOp -> condIntReg GU x y
617 AddrGeOp -> condIntReg GEU x y
618 AddrEqOp -> condIntReg EQQ x y
619 AddrNeOp -> condIntReg NE x y
620 AddrLtOp -> condIntReg LU x y
621 AddrLeOp -> condIntReg LEU x y
623 FloatGtOp -> condFltReg GTT x y
624 FloatGeOp -> condFltReg GE x y
625 FloatEqOp -> condFltReg EQQ x y
626 FloatNeOp -> condFltReg NE x y
627 FloatLtOp -> condFltReg LTT x y
628 FloatLeOp -> condFltReg LE x y
630 DoubleGtOp -> condFltReg GTT x y
631 DoubleGeOp -> condFltReg GE x y
632 DoubleEqOp -> condFltReg EQQ x y
633 DoubleNeOp -> condFltReg NE x y
634 DoubleLtOp -> condFltReg LTT x y
635 DoubleLeOp -> condFltReg LE x y
637 IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
638 -- this should be optimised by the generic Opts,
639 -- I don't know why it is not (sometimes)!
641 [x, StInt 0] -> getRegister x
646 IntSubOp -> sub_code L x y
647 IntQuotOp -> quot_code L x y True{-division-}
648 IntRemOp -> quot_code L x y False{-remainder-}
649 IntMulOp -> trivialCode (IMUL L) x y {-True-}
651 FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
652 FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
653 FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
654 FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
656 DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
657 DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
658 DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
659 DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
661 AndOp -> trivialCode (AND L) x y {-True-}
662 OrOp -> trivialCode (OR L) x y {-True-}
663 XorOp -> trivialCode (XOR L) x y {-True-}
665 {- Shift ops on x86s have constraints on their source, it
666 either has to be Imm, CL or 1
667 => trivialCode's is not restrictive enough (sigh.)
670 SllOp -> shift_code (SHL L) x y {-False-}
671 SraOp -> shift_code (SAR L) x y {-False-}
672 SrlOp -> shift_code (SHR L) x y {-False-}
675 ISllOp -> panic "I386Gen:isll"
676 ISraOp -> panic "I386Gen:isra"
677 ISrlOp -> panic "I386Gen:isrl"
679 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
680 where promote x = StPrim Float2DoubleOp [x]
681 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
683 shift_code :: (Operand -> Operand -> Instr)
687 {- Case1: shift length as immediate -}
688 -- Code is the same as the first eq. for trivialCode -- sigh.
689 shift_code instr x y{-amount-}
691 = getRegister x `thenUs` \ register ->
693 op_imm = OpImm imm__2
696 code = registerCode register dst
697 src = registerName register dst
699 mkSeqInstr (COMMENT SLIT("shift_code")) .
701 if isFixed register && src /= dst
703 mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
704 instr op_imm (OpReg dst)]
706 mkSeqInstr (instr op_imm (OpReg src))
708 returnUs (Any IntRep code__2)
711 imm__2 = case imm of Just x -> x
713 {- Case2: shift length is complex (non-immediate) -}
714 shift_code instr x y{-amount-}
715 = getRegister y `thenUs` \ register1 ->
716 getRegister x `thenUs` \ register2 ->
717 -- getNewRegNCG IntRep `thenUs` \ dst ->
719 -- Note: we force the shift length to be loaded
720 -- into ECX, so that we can use CL when shifting.
721 -- (only register location we are allowed
722 -- to put shift amounts.)
724 -- The shift instruction is fed ECX as src reg,
725 -- but we coerce this into CL when printing out.
726 src1 = registerName register1 ecx
727 code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
728 registerCode register1 ecx .
729 mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
731 registerCode register1 ecx
734 code2 = registerCode register2 eax
735 src2 = registerName register2 eax
738 mkSeqInstr (instr (OpReg ecx) (OpReg eax))
740 returnUs (Fixed IntRep eax code__2)
742 add_code :: Size -> StixTree -> StixTree -> UniqSM Register
744 add_code sz x (StInt y)
745 = getRegister x `thenUs` \ register ->
746 getNewRegNCG IntRep `thenUs` \ tmp ->
748 code = registerCode register tmp
749 src1 = registerName register tmp
750 src2 = ImmInt (fromInteger y)
752 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
754 returnUs (Any IntRep code__2)
756 add_code sz x (StInd _ mem)
757 = getRegister x `thenUs` \ register1 ->
758 --getNewRegNCG (registerRep register1)
759 -- `thenUs` \ tmp1 ->
760 getAmode mem `thenUs` \ amode ->
762 code2 = amodeCode amode
763 src2 = amodeAddr amode
765 -- fixedname = registerName register1 eax
766 code__2 dst = let code1 = registerCode register1 dst
767 src1 = registerName register1 dst
768 in asmParThen [code2 asmVoid,code1 asmVoid] .
769 if isFixed register1 && src1 /= dst
770 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
771 ADD sz (OpAddr src2) (OpReg dst)]
773 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
775 returnUs (Any IntRep code__2)
777 add_code sz (StInd _ mem) y
778 = getRegister y `thenUs` \ register2 ->
779 --getNewRegNCG (registerRep register2)
780 -- `thenUs` \ tmp2 ->
781 getAmode mem `thenUs` \ amode ->
783 code1 = amodeCode amode
784 src1 = amodeAddr amode
786 -- fixedname = registerName register2 eax
787 code__2 dst = let code2 = registerCode register2 dst
788 src2 = registerName register2 dst
789 in asmParThen [code1 asmVoid,code2 asmVoid] .
790 if isFixed register2 && src2 /= dst
791 then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
792 ADD sz (OpAddr src1) (OpReg dst)]
794 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
796 returnUs (Any IntRep code__2)
799 = getRegister x `thenUs` \ register1 ->
800 getRegister y `thenUs` \ register2 ->
801 getNewRegNCG IntRep `thenUs` \ tmp1 ->
802 getNewRegNCG IntRep `thenUs` \ tmp2 ->
804 code1 = registerCode register1 tmp1 asmVoid
805 src1 = registerName register1 tmp1
806 code2 = registerCode register2 tmp2 asmVoid
807 src2 = registerName register2 tmp2
808 code__2 dst = asmParThen [code1, code2] .
809 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
811 returnUs (Any IntRep code__2)
814 sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
816 sub_code sz x (StInt y)
817 = getRegister x `thenUs` \ register ->
818 getNewRegNCG IntRep `thenUs` \ tmp ->
820 code = registerCode register tmp
821 src1 = registerName register tmp
822 src2 = ImmInt (-(fromInteger y))
824 mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
826 returnUs (Any IntRep code__2)
828 sub_code sz x y = trivialCode (SUB sz) x y {-False-}
833 -> StixTree -> StixTree
834 -> Bool -- True => division, False => remainder operation
837 -- x must go into eax, edx must be a sign-extension of eax, and y
838 -- should go in some other register (or memory), so that we get
839 -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
840 -- put y in memory (if it is not there already)
842 quot_code sz x (StInd pk mem) is_division
843 = getRegister x `thenUs` \ register1 ->
844 getNewRegNCG IntRep `thenUs` \ tmp1 ->
845 getAmode mem `thenUs` \ amode ->
847 code1 = registerCode register1 tmp1 asmVoid
848 src1 = registerName register1 tmp1
849 code2 = amodeCode amode asmVoid
850 src2 = amodeAddr amode
851 code__2 = asmParThen [code1, code2] .
852 mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
854 IDIV sz (OpAddr src2)]
856 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
858 quot_code sz x (StInt i) is_division
859 = getRegister x `thenUs` \ register1 ->
860 getNewRegNCG IntRep `thenUs` \ tmp1 ->
862 code1 = registerCode register1 tmp1 asmVoid
863 src1 = registerName register1 tmp1
864 src2 = ImmInt (fromInteger i)
865 code__2 = asmParThen [code1] .
866 mkSeqInstrs [-- we put src2 in (ebx)
867 MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
868 MOV L (OpReg src1) (OpReg eax),
870 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
872 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
874 quot_code sz x y is_division
875 = getRegister x `thenUs` \ register1 ->
876 getNewRegNCG IntRep `thenUs` \ tmp1 ->
877 getRegister y `thenUs` \ register2 ->
878 getNewRegNCG IntRep `thenUs` \ tmp2 ->
880 code1 = registerCode register1 tmp1 asmVoid
881 src1 = registerName register1 tmp1
882 code2 = registerCode register2 tmp2 asmVoid
883 src2 = registerName register2 tmp2
884 code__2 = asmParThen [code1, code2] .
885 if src2 == ecx || src2 == esi
886 then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
888 IDIV sz (OpReg src2)]
889 else mkSeqInstrs [ -- we put src2 in (ebx)
890 MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
891 MOV L (OpReg src1) (OpReg eax),
893 IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
895 returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
896 -----------------------
898 getRegister (StInd pk mem)
899 = getAmode mem `thenUs` \ amode ->
901 code = amodeCode amode
902 src = amodeAddr amode
903 size = primRepToSize pk
905 if pk == DoubleRep || pk == FloatRep
906 then mkSeqInstr (FLD {-DF-} size (OpAddr src))
907 else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
909 returnUs (Any pk code__2)
912 getRegister (StInt i)
914 src = ImmInt (fromInteger i)
915 code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
917 returnUs (Any IntRep code)
922 code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
924 returnUs (Any PtrRep code)
927 imm__2 = case imm of Just x -> x
929 #endif {- i386_TARGET_ARCH -}
930 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
931 #if sparc_TARGET_ARCH
933 getRegister (StDouble d)
934 = getUniqLabelNCG `thenUs` \ lbl ->
935 getNewRegNCG PtrRep `thenUs` \ tmp ->
936 let code dst = mkSeqInstrs [
939 DATA DF [dblImmLit d],
941 SETHI (HI (ImmCLbl lbl)) tmp,
942 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
944 returnUs (Any DoubleRep code)
946 getRegister (StPrim primop [x]) -- unary PrimOps
948 IntNegOp -> trivialUCode (SUB False False g0) x
949 IntAbsOp -> absIntCode x
950 NotOp -> trivialUCode (XNOR False g0) x
952 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
954 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
956 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
957 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
959 OrdOp -> coerceIntCode IntRep x
962 Float2IntOp -> coerceFP2Int x
963 Int2FloatOp -> coerceInt2FP FloatRep x
964 Double2IntOp -> coerceFP2Int x
965 Int2DoubleOp -> coerceInt2FP DoubleRep x
969 fixed_x = if is_float_op -- promote to double
970 then StPrim Float2DoubleOp [x]
973 getRegister (StCall fn DoubleRep [x])
977 FloatExpOp -> (True, SLIT("exp"))
978 FloatLogOp -> (True, SLIT("log"))
979 FloatSqrtOp -> (True, SLIT("sqrt"))
981 FloatSinOp -> (True, SLIT("sin"))
982 FloatCosOp -> (True, SLIT("cos"))
983 FloatTanOp -> (True, SLIT("tan"))
985 FloatAsinOp -> (True, SLIT("asin"))
986 FloatAcosOp -> (True, SLIT("acos"))
987 FloatAtanOp -> (True, SLIT("atan"))
989 FloatSinhOp -> (True, SLIT("sinh"))
990 FloatCoshOp -> (True, SLIT("cosh"))
991 FloatTanhOp -> (True, SLIT("tanh"))
993 DoubleExpOp -> (False, SLIT("exp"))
994 DoubleLogOp -> (False, SLIT("log"))
995 DoubleSqrtOp -> (True, SLIT("sqrt"))
997 DoubleSinOp -> (False, SLIT("sin"))
998 DoubleCosOp -> (False, SLIT("cos"))
999 DoubleTanOp -> (False, SLIT("tan"))
1001 DoubleAsinOp -> (False, SLIT("asin"))
1002 DoubleAcosOp -> (False, SLIT("acos"))
1003 DoubleAtanOp -> (False, SLIT("atan"))
1005 DoubleSinhOp -> (False, SLIT("sinh"))
1006 DoubleCoshOp -> (False, SLIT("cosh"))
1007 DoubleTanhOp -> (False, SLIT("tanh"))
1008 _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
1010 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1012 CharGtOp -> condIntReg GTT x y
1013 CharGeOp -> condIntReg GE x y
1014 CharEqOp -> condIntReg EQQ x y
1015 CharNeOp -> condIntReg NE x y
1016 CharLtOp -> condIntReg LTT x y
1017 CharLeOp -> condIntReg LE x y
1019 IntGtOp -> condIntReg GTT x y
1020 IntGeOp -> condIntReg GE x y
1021 IntEqOp -> condIntReg EQQ x y
1022 IntNeOp -> condIntReg NE x y
1023 IntLtOp -> condIntReg LTT x y
1024 IntLeOp -> condIntReg LE x y
1026 WordGtOp -> condIntReg GU x y
1027 WordGeOp -> condIntReg GEU x y
1028 WordEqOp -> condIntReg EQQ x y
1029 WordNeOp -> condIntReg NE x y
1030 WordLtOp -> condIntReg LU x y
1031 WordLeOp -> condIntReg LEU x y
1033 AddrGtOp -> condIntReg GU x y
1034 AddrGeOp -> condIntReg GEU x y
1035 AddrEqOp -> condIntReg EQQ x y
1036 AddrNeOp -> condIntReg NE x y
1037 AddrLtOp -> condIntReg LU x y
1038 AddrLeOp -> condIntReg LEU x y
1040 FloatGtOp -> condFltReg GTT x y
1041 FloatGeOp -> condFltReg GE x y
1042 FloatEqOp -> condFltReg EQQ x y
1043 FloatNeOp -> condFltReg NE x y
1044 FloatLtOp -> condFltReg LTT x y
1045 FloatLeOp -> condFltReg LE x y
1047 DoubleGtOp -> condFltReg GTT x y
1048 DoubleGeOp -> condFltReg GE x y
1049 DoubleEqOp -> condFltReg EQQ x y
1050 DoubleNeOp -> condFltReg NE x y
1051 DoubleLtOp -> condFltReg LTT x y
1052 DoubleLeOp -> condFltReg LE x y
1054 IntAddOp -> trivialCode (ADD False False) x y
1055 IntSubOp -> trivialCode (SUB False False) x y
1057 -- ToDo: teach about V8+ SPARC mul/div instructions
1058 IntMulOp -> imul_div SLIT(".umul") x y
1059 IntQuotOp -> imul_div SLIT(".div") x y
1060 IntRemOp -> imul_div SLIT(".rem") x y
1062 FloatAddOp -> trivialFCode FloatRep FADD x y
1063 FloatSubOp -> trivialFCode FloatRep FSUB x y
1064 FloatMulOp -> trivialFCode FloatRep FMUL x y
1065 FloatDivOp -> trivialFCode FloatRep FDIV x y
1067 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1068 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1069 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1070 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1072 AndOp -> trivialCode (AND False) x y
1073 OrOp -> trivialCode (OR False) x y
1074 XorOp -> trivialCode (XOR False) x y
1075 SllOp -> trivialCode SLL x y
1076 SraOp -> trivialCode SRA x y
1077 SrlOp -> trivialCode SRL x y
1079 ISllOp -> panic "SparcGen:isll"
1080 ISraOp -> panic "SparcGen:isra"
1081 ISrlOp -> panic "SparcGen:isrl"
1083 FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1084 where promote x = StPrim Float2DoubleOp [x]
1085 DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1086 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1088 imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1090 getRegister (StInd pk mem)
1091 = getAmode mem `thenUs` \ amode ->
1093 code = amodeCode amode
1094 src = amodeAddr amode
1095 size = primRepToSize pk
1096 code__2 dst = code . mkSeqInstr (LD size src dst)
1098 returnUs (Any pk code__2)
1100 getRegister (StInt i)
1103 src = ImmInt (fromInteger i)
1104 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1106 returnUs (Any IntRep code)
1111 code dst = mkSeqInstrs [
1112 SETHI (HI imm__2) dst,
1113 OR False dst (RIImm (LO imm__2)) dst]
1115 returnUs (Any PtrRep code)
1118 imm__2 = case imm of Just x -> x
1120 #endif {- sparc_TARGET_ARCH -}
1123 %************************************************************************
1125 \subsection{The @Amode@ type}
1127 %************************************************************************
1129 @Amode@s: Memory addressing modes passed up the tree.
1131 data Amode = Amode MachRegsAddr InstrBlock
1133 amodeAddr (Amode addr _) = addr
1134 amodeCode (Amode _ code) = code
1137 Now, given a tree (the argument to an StInd) that references memory,
1138 produce a suitable addressing mode.
1141 getAmode :: StixTree -> UniqSM Amode
1143 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1145 #if alpha_TARGET_ARCH
1147 getAmode (StPrim IntSubOp [x, StInt i])
1148 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1149 getRegister x `thenUs` \ register ->
1151 code = registerCode register tmp
1152 reg = registerName register tmp
1153 off = ImmInt (-(fromInteger i))
1155 returnUs (Amode (AddrRegImm reg off) code)
1157 getAmode (StPrim IntAddOp [x, StInt i])
1158 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1159 getRegister x `thenUs` \ register ->
1161 code = registerCode register tmp
1162 reg = registerName register tmp
1163 off = ImmInt (fromInteger i)
1165 returnUs (Amode (AddrRegImm reg off) code)
1169 = returnUs (Amode (AddrImm imm__2) id)
1172 imm__2 = case imm of Just x -> x
1175 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1176 getRegister other `thenUs` \ register ->
1178 code = registerCode register tmp
1179 reg = registerName register tmp
1181 returnUs (Amode (AddrReg reg) code)
1183 #endif {- alpha_TARGET_ARCH -}
1184 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1185 #if i386_TARGET_ARCH
1187 getAmode (StPrim IntSubOp [x, StInt i])
1188 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1189 getRegister x `thenUs` \ register ->
1191 code = registerCode register tmp
1192 reg = registerName register tmp
1193 off = ImmInt (-(fromInteger i))
1195 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1197 getAmode (StPrim IntAddOp [x, StInt i])
1200 code = mkSeqInstrs []
1202 returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1205 imm__2 = case imm of Just x -> x
1207 getAmode (StPrim IntAddOp [x, StInt i])
1208 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1209 getRegister x `thenUs` \ register ->
1211 code = registerCode register tmp
1212 reg = registerName register tmp
1213 off = ImmInt (fromInteger i)
1215 returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1217 getAmode (StPrim IntAddOp [x, y])
1218 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1219 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1220 getRegister x `thenUs` \ register1 ->
1221 getRegister y `thenUs` \ register2 ->
1223 code1 = registerCode register1 tmp1 asmVoid
1224 reg1 = registerName register1 tmp1
1225 code2 = registerCode register2 tmp2 asmVoid
1226 reg2 = registerName register2 tmp2
1227 code__2 = asmParThen [code1, code2]
1229 returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1234 code = mkSeqInstrs []
1236 returnUs (Amode (ImmAddr imm__2 0) code)
1239 imm__2 = case imm of Just x -> x
1242 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1243 getRegister other `thenUs` \ register ->
1245 code = registerCode register tmp
1246 reg = registerName register tmp
1249 returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1251 #endif {- i386_TARGET_ARCH -}
1252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1253 #if sparc_TARGET_ARCH
1255 getAmode (StPrim IntSubOp [x, StInt i])
1257 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1258 getRegister x `thenUs` \ register ->
1260 code = registerCode register tmp
1261 reg = registerName register tmp
1262 off = ImmInt (-(fromInteger i))
1264 returnUs (Amode (AddrRegImm reg off) code)
1267 getAmode (StPrim IntAddOp [x, StInt i])
1269 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1270 getRegister x `thenUs` \ register ->
1272 code = registerCode register tmp
1273 reg = registerName register tmp
1274 off = ImmInt (fromInteger i)
1276 returnUs (Amode (AddrRegImm reg off) code)
1278 getAmode (StPrim IntAddOp [x, y])
1279 = getNewRegNCG PtrRep `thenUs` \ tmp1 ->
1280 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1281 getRegister x `thenUs` \ register1 ->
1282 getRegister y `thenUs` \ register2 ->
1284 code1 = registerCode register1 tmp1 asmVoid
1285 reg1 = registerName register1 tmp1
1286 code2 = registerCode register2 tmp2 asmVoid
1287 reg2 = registerName register2 tmp2
1288 code__2 = asmParThen [code1, code2]
1290 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1294 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1296 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1298 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1301 imm__2 = case imm of Just x -> x
1304 = getNewRegNCG PtrRep `thenUs` \ tmp ->
1305 getRegister other `thenUs` \ register ->
1307 code = registerCode register tmp
1308 reg = registerName register tmp
1311 returnUs (Amode (AddrRegImm reg off) code)
1313 #endif {- sparc_TARGET_ARCH -}
1316 %************************************************************************
1318 \subsection{The @CondCode@ type}
1320 %************************************************************************
1322 Condition codes passed up the tree.
1324 data CondCode = CondCode Bool Cond InstrBlock
1326 condName (CondCode _ cond _) = cond
1327 condFloat (CondCode is_float _ _) = is_float
1328 condCode (CondCode _ _ code) = code
1331 Set up a condition code for a conditional branch.
1334 getCondCode :: StixTree -> UniqSM CondCode
1336 #if alpha_TARGET_ARCH
1337 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1338 #endif {- alpha_TARGET_ARCH -}
1339 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1341 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1342 -- yes, they really do seem to want exactly the same!
1344 getCondCode (StPrim primop [x, y])
1346 CharGtOp -> condIntCode GTT x y
1347 CharGeOp -> condIntCode GE x y
1348 CharEqOp -> condIntCode EQQ x y
1349 CharNeOp -> condIntCode NE x y
1350 CharLtOp -> condIntCode LTT x y
1351 CharLeOp -> condIntCode LE x y
1353 IntGtOp -> condIntCode GTT x y
1354 IntGeOp -> condIntCode GE x y
1355 IntEqOp -> condIntCode EQQ x y
1356 IntNeOp -> condIntCode NE x y
1357 IntLtOp -> condIntCode LTT x y
1358 IntLeOp -> condIntCode LE x y
1360 WordGtOp -> condIntCode GU x y
1361 WordGeOp -> condIntCode GEU x y
1362 WordEqOp -> condIntCode EQQ x y
1363 WordNeOp -> condIntCode NE x y
1364 WordLtOp -> condIntCode LU x y
1365 WordLeOp -> condIntCode LEU x y
1367 AddrGtOp -> condIntCode GU x y
1368 AddrGeOp -> condIntCode GEU x y
1369 AddrEqOp -> condIntCode EQQ x y
1370 AddrNeOp -> condIntCode NE x y
1371 AddrLtOp -> condIntCode LU x y
1372 AddrLeOp -> condIntCode LEU x y
1374 FloatGtOp -> condFltCode GTT x y
1375 FloatGeOp -> condFltCode GE x y
1376 FloatEqOp -> condFltCode EQQ x y
1377 FloatNeOp -> condFltCode NE x y
1378 FloatLtOp -> condFltCode LTT x y
1379 FloatLeOp -> condFltCode LE x y
1381 DoubleGtOp -> condFltCode GTT x y
1382 DoubleGeOp -> condFltCode GE x y
1383 DoubleEqOp -> condFltCode EQQ x y
1384 DoubleNeOp -> condFltCode NE x y
1385 DoubleLtOp -> condFltCode LTT x y
1386 DoubleLeOp -> condFltCode LE x y
1388 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1393 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1394 passed back up the tree.
1397 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1399 #if alpha_TARGET_ARCH
1400 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1401 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1402 #endif {- alpha_TARGET_ARCH -}
1404 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1405 #if i386_TARGET_ARCH
1407 condIntCode cond (StInd _ x) y
1409 = getAmode x `thenUs` \ amode ->
1411 code1 = amodeCode amode asmVoid
1412 y__2 = amodeAddr amode
1413 code__2 = asmParThen [code1] .
1414 mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1416 returnUs (CondCode False cond code__2)
1419 imm__2 = case imm of Just x -> x
1421 condIntCode cond x (StInt 0)
1422 = getRegister x `thenUs` \ register1 ->
1423 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1425 code1 = registerCode register1 tmp1 asmVoid
1426 src1 = registerName register1 tmp1
1427 code__2 = asmParThen [code1] .
1428 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1430 returnUs (CondCode False cond code__2)
1432 condIntCode cond x y
1434 = getRegister x `thenUs` \ register1 ->
1435 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1437 code1 = registerCode register1 tmp1 asmVoid
1438 src1 = registerName register1 tmp1
1439 code__2 = asmParThen [code1] .
1440 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1442 returnUs (CondCode False cond code__2)
1445 imm__2 = case imm of Just x -> x
1447 condIntCode cond (StInd _ x) y
1448 = getAmode x `thenUs` \ amode ->
1449 getRegister y `thenUs` \ register2 ->
1450 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1452 code1 = amodeCode amode asmVoid
1453 src1 = amodeAddr amode
1454 code2 = registerCode register2 tmp2 asmVoid
1455 src2 = registerName register2 tmp2
1456 code__2 = asmParThen [code1, code2] .
1457 mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1459 returnUs (CondCode False cond code__2)
1461 condIntCode cond y (StInd _ x)
1462 = getAmode x `thenUs` \ amode ->
1463 getRegister y `thenUs` \ register2 ->
1464 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1466 code1 = amodeCode amode asmVoid
1467 src1 = amodeAddr amode
1468 code2 = registerCode register2 tmp2 asmVoid
1469 src2 = registerName register2 tmp2
1470 code__2 = asmParThen [code1, code2] .
1471 mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1473 returnUs (CondCode False cond code__2)
1475 condIntCode cond x y
1476 = getRegister x `thenUs` \ register1 ->
1477 getRegister y `thenUs` \ register2 ->
1478 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1479 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1481 code1 = registerCode register1 tmp1 asmVoid
1482 src1 = registerName register1 tmp1
1483 code2 = registerCode register2 tmp2 asmVoid
1484 src2 = registerName register2 tmp2
1485 code__2 = asmParThen [code1, code2] .
1486 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1488 returnUs (CondCode False cond code__2)
1492 condFltCode cond x (StDouble 0.0)
1493 = getRegister x `thenUs` \ register1 ->
1494 getNewRegNCG (registerRep register1)
1497 pk1 = registerRep register1
1498 code1 = registerCode register1 tmp1
1499 src1 = registerName register1 tmp1
1501 code__2 = asmParThen [code1 asmVoid] .
1502 mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1504 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1505 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1509 returnUs (CondCode True (fix_FP_cond cond) code__2)
1511 condFltCode cond x y
1512 = getRegister x `thenUs` \ register1 ->
1513 getRegister y `thenUs` \ register2 ->
1514 getNewRegNCG (registerRep register1)
1516 getNewRegNCG (registerRep register2)
1519 pk1 = registerRep register1
1520 code1 = registerCode register1 tmp1
1521 src1 = registerName register1 tmp1
1523 code2 = registerCode register2 tmp2
1524 src2 = registerName register2 tmp2
1526 code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1527 mkSeqInstrs [FUCOMPP,
1529 --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1530 --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1534 returnUs (CondCode True (fix_FP_cond cond) code__2)
1536 {- On the 486, the flags set by FP compare are the unsigned ones!
1537 (This looks like a HACK to me. WDP 96/03)
1540 fix_FP_cond :: Cond -> Cond
1542 fix_FP_cond GE = GEU
1543 fix_FP_cond GTT = GU
1544 fix_FP_cond LTT = LU
1545 fix_FP_cond LE = LEU
1546 fix_FP_cond any = any
1548 #endif {- i386_TARGET_ARCH -}
1549 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1550 #if sparc_TARGET_ARCH
1552 condIntCode cond x (StInt y)
1554 = getRegister x `thenUs` \ register ->
1555 getNewRegNCG IntRep `thenUs` \ tmp ->
1557 code = registerCode register tmp
1558 src1 = registerName register tmp
1559 src2 = ImmInt (fromInteger y)
1560 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1562 returnUs (CondCode False cond code__2)
1564 condIntCode cond x y
1565 = getRegister x `thenUs` \ register1 ->
1566 getRegister y `thenUs` \ register2 ->
1567 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1568 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1570 code1 = registerCode register1 tmp1 asmVoid
1571 src1 = registerName register1 tmp1
1572 code2 = registerCode register2 tmp2 asmVoid
1573 src2 = registerName register2 tmp2
1574 code__2 = asmParThen [code1, code2] .
1575 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1577 returnUs (CondCode False cond code__2)
1580 condFltCode cond x y
1581 = getRegister x `thenUs` \ register1 ->
1582 getRegister y `thenUs` \ register2 ->
1583 getNewRegNCG (registerRep register1)
1585 getNewRegNCG (registerRep register2)
1587 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1589 promote x = asmInstr (FxTOy F DF x tmp)
1591 pk1 = registerRep register1
1592 code1 = registerCode register1 tmp1
1593 src1 = registerName register1 tmp1
1595 pk2 = registerRep register2
1596 code2 = registerCode register2 tmp2
1597 src2 = registerName register2 tmp2
1601 asmParThen [code1 asmVoid, code2 asmVoid] .
1602 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1603 else if pk1 == FloatRep then
1604 asmParThen [code1 (promote src1), code2 asmVoid] .
1605 mkSeqInstr (FCMP True DF tmp src2)
1607 asmParThen [code1 asmVoid, code2 (promote src2)] .
1608 mkSeqInstr (FCMP True DF src1 tmp)
1610 returnUs (CondCode True cond code__2)
1612 #endif {- sparc_TARGET_ARCH -}
1615 %************************************************************************
1617 \subsection{Generating assignments}
1619 %************************************************************************
1621 Assignments are really at the heart of the whole code generation
1622 business. Almost all top-level nodes of any real importance are
1623 assignments, which correspond to loads, stores, or register transfers.
1624 If we're really lucky, some of the register transfers will go away,
1625 because we can use the destination register to complete the code
1626 generation for the right hand side. This only fails when the right
1627 hand side is forced into a fixed register (e.g. the result of a call).
1630 assignIntCode, assignFltCode
1631 :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1633 #if alpha_TARGET_ARCH
1635 assignIntCode pk (StInd _ dst) src
1636 = getNewRegNCG IntRep `thenUs` \ tmp ->
1637 getAmode dst `thenUs` \ amode ->
1638 getRegister src `thenUs` \ register ->
1640 code1 = amodeCode amode asmVoid
1641 dst__2 = amodeAddr amode
1642 code2 = registerCode register tmp asmVoid
1643 src__2 = registerName register tmp
1644 sz = primRepToSize pk
1645 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1649 assignIntCode pk dst src
1650 = getRegister dst `thenUs` \ register1 ->
1651 getRegister src `thenUs` \ register2 ->
1653 dst__2 = registerName register1 zeroh
1654 code = registerCode register2 dst__2
1655 src__2 = registerName register2 dst__2
1656 code__2 = if isFixed register2
1657 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1662 #endif {- alpha_TARGET_ARCH -}
1663 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1664 #if i386_TARGET_ARCH
1666 assignIntCode pk (StInd _ dst) src
1667 = getAmode dst `thenUs` \ amode ->
1668 get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
1670 code1 = amodeCode amode asmVoid
1671 dst__2 = amodeAddr amode
1672 code__2 = asmParThen [code1, codesrc asmVoid] .
1673 mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1679 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
1683 = returnUs (asmParThen [], OpImm imm_op, L)
1686 imm_op = case imm of Just x -> x
1689 = getRegister op `thenUs` \ register ->
1690 getNewRegNCG (registerRep register)
1693 code = registerCode register tmp
1694 reg = registerName register tmp
1695 pk = registerRep register
1696 sz = primRepToSize pk
1698 returnUs (code, OpReg reg, sz)
1700 assignIntCode pk dst (StInd _ src)
1701 = getNewRegNCG IntRep `thenUs` \ tmp ->
1702 getAmode src `thenUs` \ amode ->
1703 getRegister dst `thenUs` \ register ->
1705 code1 = amodeCode amode asmVoid
1706 src__2 = amodeAddr amode
1707 code2 = registerCode register tmp asmVoid
1708 dst__2 = registerName register tmp
1709 sz = primRepToSize pk
1710 code__2 = asmParThen [code1, code2] .
1711 mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1715 assignIntCode pk dst src
1716 = getRegister dst `thenUs` \ register1 ->
1717 getRegister src `thenUs` \ register2 ->
1718 getNewRegNCG IntRep `thenUs` \ tmp ->
1720 dst__2 = registerName register1 tmp
1721 code = registerCode register2 dst__2
1722 src__2 = registerName register2 dst__2
1723 code__2 = if isFixed register2 && dst__2 /= src__2
1724 then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1729 #endif {- i386_TARGET_ARCH -}
1730 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1731 #if sparc_TARGET_ARCH
1733 assignIntCode pk (StInd _ dst) src
1734 = getNewRegNCG IntRep `thenUs` \ tmp ->
1735 getAmode dst `thenUs` \ amode ->
1736 getRegister src `thenUs` \ register ->
1738 code1 = amodeCode amode asmVoid
1739 dst__2 = amodeAddr amode
1740 code2 = registerCode register tmp asmVoid
1741 src__2 = registerName register tmp
1742 sz = primRepToSize pk
1743 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1747 assignIntCode pk dst src
1748 = getRegister dst `thenUs` \ register1 ->
1749 getRegister src `thenUs` \ register2 ->
1751 dst__2 = registerName register1 g0
1752 code = registerCode register2 dst__2
1753 src__2 = registerName register2 dst__2
1754 code__2 = if isFixed register2
1755 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1760 #endif {- sparc_TARGET_ARCH -}
1763 % --------------------------------
1764 Floating-point assignments:
1765 % --------------------------------
1767 #if alpha_TARGET_ARCH
1769 assignFltCode pk (StInd _ dst) src
1770 = getNewRegNCG pk `thenUs` \ tmp ->
1771 getAmode dst `thenUs` \ amode ->
1772 getRegister src `thenUs` \ register ->
1774 code1 = amodeCode amode asmVoid
1775 dst__2 = amodeAddr amode
1776 code2 = registerCode register tmp asmVoid
1777 src__2 = registerName register tmp
1778 sz = primRepToSize pk
1779 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1783 assignFltCode pk dst src
1784 = getRegister dst `thenUs` \ register1 ->
1785 getRegister src `thenUs` \ register2 ->
1787 dst__2 = registerName register1 zeroh
1788 code = registerCode register2 dst__2
1789 src__2 = registerName register2 dst__2
1790 code__2 = if isFixed register2
1791 then code . mkSeqInstr (FMOV src__2 dst__2)
1796 #endif {- alpha_TARGET_ARCH -}
1797 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1798 #if i386_TARGET_ARCH
1800 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1801 = getNewRegNCG IntRep `thenUs` \ tmp ->
1802 getAmode src `thenUs` \ amodesrc ->
1803 getAmode dst `thenUs` \ amodedst ->
1804 --getRegister src `thenUs` \ register ->
1806 codesrc1 = amodeCode amodesrc asmVoid
1807 addrsrc1 = amodeAddr amodesrc
1808 codedst1 = amodeCode amodedst asmVoid
1809 addrdst1 = amodeAddr amodedst
1810 addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1811 addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1813 code__2 = asmParThen [codesrc1, codedst1] .
1814 mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1815 MOV L (OpReg tmp) (OpAddr addrdst1)]
1818 then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1819 MOV L (OpReg tmp) (OpAddr addrdst2)]
1824 assignFltCode pk (StInd _ dst) src
1825 = --getNewRegNCG pk `thenUs` \ tmp ->
1826 getAmode dst `thenUs` \ amode ->
1827 getRegister src `thenUs` \ register ->
1829 sz = primRepToSize pk
1830 dst__2 = amodeAddr amode
1832 code1 = amodeCode amode asmVoid
1833 code2 = registerCode register {-tmp-}st0 asmVoid
1835 --src__2= registerName register tmp
1836 pk__2 = registerRep register
1837 sz__2 = primRepToSize pk__2
1839 code__2 = asmParThen [code1, code2] .
1840 mkSeqInstr (FSTP sz (OpAddr dst__2))
1844 assignFltCode pk dst src
1845 = getRegister dst `thenUs` \ register1 ->
1846 getRegister src `thenUs` \ register2 ->
1847 --getNewRegNCG (registerRep register2)
1848 -- `thenUs` \ tmp ->
1850 sz = primRepToSize pk
1851 dst__2 = registerName register1 st0 --tmp
1853 code = registerCode register2 dst__2
1854 src__2 = registerName register2 dst__2
1860 #endif {- i386_TARGET_ARCH -}
1861 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1862 #if sparc_TARGET_ARCH
1864 assignFltCode pk (StInd _ dst) src
1865 = getNewRegNCG pk `thenUs` \ tmp1 ->
1866 getAmode dst `thenUs` \ amode ->
1867 getRegister src `thenUs` \ register ->
1869 sz = primRepToSize pk
1870 dst__2 = amodeAddr amode
1872 code1 = amodeCode amode asmVoid
1873 code2 = registerCode register tmp1 asmVoid
1875 src__2 = registerName register tmp1
1876 pk__2 = registerRep register
1877 sz__2 = primRepToSize pk__2
1879 code__2 = asmParThen [code1, code2] .
1881 mkSeqInstr (ST sz src__2 dst__2)
1883 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1887 assignFltCode pk dst src
1888 = getRegister dst `thenUs` \ register1 ->
1889 getRegister src `thenUs` \ register2 ->
1891 pk__2 = registerRep register2
1892 sz__2 = primRepToSize pk__2
1894 getNewRegNCG pk__2 `thenUs` \ tmp ->
1896 sz = primRepToSize pk
1897 dst__2 = registerName register1 g0 -- must be Fixed
1900 reg__2 = if pk /= pk__2 then tmp else dst__2
1902 code = registerCode register2 reg__2
1904 src__2 = registerName register2 reg__2
1908 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1909 else if isFixed register2 then
1910 code . mkSeqInstr (FMOV sz src__2 dst__2)
1916 #endif {- sparc_TARGET_ARCH -}
1919 %************************************************************************
1921 \subsection{Generating an unconditional branch}
1923 %************************************************************************
1925 We accept two types of targets: an immediate CLabel or a tree that
1926 gets evaluated into a register. Any CLabels which are AsmTemporaries
1927 are assumed to be in the local block of code, close enough for a
1928 branch instruction. Other CLabels are assumed to be far away.
1930 (If applicable) Do not fill the delay slots here; you will confuse the
1934 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1936 #if alpha_TARGET_ARCH
1938 genJump (StCLbl lbl)
1939 | isAsmTemp lbl = returnInstr (BR target)
1940 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1942 target = ImmCLbl lbl
1945 = getRegister tree `thenUs` \ register ->
1946 getNewRegNCG PtrRep `thenUs` \ tmp ->
1948 dst = registerName register pv
1949 code = registerCode register pv
1950 target = registerName register pv
1952 if isFixed register then
1953 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1955 returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1957 #endif {- alpha_TARGET_ARCH -}
1958 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1959 #if i386_TARGET_ARCH
1962 genJump (StCLbl lbl)
1963 | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1964 | otherwise = returnInstrs [JMP (OpImm target)]
1966 target = ImmCLbl lbl
1969 genJump (StInd pk mem)
1970 = getAmode mem `thenUs` \ amode ->
1972 code = amodeCode amode
1973 target = amodeAddr amode
1975 returnSeq code [JMP (OpAddr target)]
1979 = returnInstr (JMP (OpImm target))
1982 = getRegister tree `thenUs` \ register ->
1983 getNewRegNCG PtrRep `thenUs` \ tmp ->
1985 code = registerCode register tmp
1986 target = registerName register tmp
1988 returnSeq code [JMP (OpReg target)]
1991 target = case imm of Just x -> x
1993 #endif {- i386_TARGET_ARCH -}
1994 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1995 #if sparc_TARGET_ARCH
1997 genJump (StCLbl lbl)
1998 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1999 | otherwise = returnInstrs [CALL target 0 True, NOP]
2001 target = ImmCLbl lbl
2004 = getRegister tree `thenUs` \ register ->
2005 getNewRegNCG PtrRep `thenUs` \ tmp ->
2007 code = registerCode register tmp
2008 target = registerName register tmp
2010 returnSeq code [JMP (AddrRegReg target g0), NOP]
2012 #endif {- sparc_TARGET_ARCH -}
2015 %************************************************************************
2017 \subsection{Conditional jumps}
2019 %************************************************************************
2021 Conditional jumps are always to local labels, so we can use branch
2022 instructions. We peek at the arguments to decide what kind of
2025 ALPHA: For comparisons with 0, we're laughing, because we can just do
2026 the desired conditional branch.
2028 I386: First, we have to ensure that the condition
2029 codes are set according to the supplied comparison operation.
2031 SPARC: First, we have to ensure that the condition codes are set
2032 according to the supplied comparison operation. We generate slightly
2033 different code for floating point comparisons, because a floating
2034 point operation cannot directly precede a @BF@. We assume the worst
2035 and fill that slot with a @NOP@.
2037 SPARC: Do not fill the delay slots here; you will confuse the register
2042 :: CLabel -- the branch target
2043 -> StixTree -- the condition on which to branch
2044 -> UniqSM InstrBlock
2046 #if alpha_TARGET_ARCH
2048 genCondJump lbl (StPrim op [x, StInt 0])
2049 = getRegister x `thenUs` \ register ->
2050 getNewRegNCG (registerRep register)
2053 code = registerCode register tmp
2054 value = registerName register tmp
2055 pk = registerRep register
2056 target = ImmCLbl lbl
2058 returnSeq code [BI (cmpOp op) value target]
2060 cmpOp CharGtOp = GTT
2062 cmpOp CharEqOp = EQQ
2064 cmpOp CharLtOp = LTT
2073 cmpOp WordGeOp = ALWAYS
2074 cmpOp WordEqOp = EQQ
2076 cmpOp WordLtOp = NEVER
2077 cmpOp WordLeOp = EQQ
2079 cmpOp AddrGeOp = ALWAYS
2080 cmpOp AddrEqOp = EQQ
2082 cmpOp AddrLtOp = NEVER
2083 cmpOp AddrLeOp = EQQ
2085 genCondJump lbl (StPrim op [x, StDouble 0.0])
2086 = getRegister x `thenUs` \ register ->
2087 getNewRegNCG (registerRep register)
2090 code = registerCode register tmp
2091 value = registerName register tmp
2092 pk = registerRep register
2093 target = ImmCLbl lbl
2095 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2097 cmpOp FloatGtOp = GTT
2098 cmpOp FloatGeOp = GE
2099 cmpOp FloatEqOp = EQQ
2100 cmpOp FloatNeOp = NE
2101 cmpOp FloatLtOp = LTT
2102 cmpOp FloatLeOp = LE
2103 cmpOp DoubleGtOp = GTT
2104 cmpOp DoubleGeOp = GE
2105 cmpOp DoubleEqOp = EQQ
2106 cmpOp DoubleNeOp = NE
2107 cmpOp DoubleLtOp = LTT
2108 cmpOp DoubleLeOp = LE
2110 genCondJump lbl (StPrim op [x, y])
2112 = trivialFCode pr instr x y `thenUs` \ register ->
2113 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2115 code = registerCode register tmp
2116 result = registerName register tmp
2117 target = ImmCLbl lbl
2119 returnUs (code . mkSeqInstr (BF cond result target))
2121 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2123 fltCmpOp op = case op of
2137 (instr, cond) = case op of
2138 FloatGtOp -> (FCMP TF LE, EQQ)
2139 FloatGeOp -> (FCMP TF LTT, EQQ)
2140 FloatEqOp -> (FCMP TF EQQ, NE)
2141 FloatNeOp -> (FCMP TF EQQ, EQQ)
2142 FloatLtOp -> (FCMP TF LTT, NE)
2143 FloatLeOp -> (FCMP TF LE, NE)
2144 DoubleGtOp -> (FCMP TF LE, EQQ)
2145 DoubleGeOp -> (FCMP TF LTT, EQQ)
2146 DoubleEqOp -> (FCMP TF EQQ, NE)
2147 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2148 DoubleLtOp -> (FCMP TF LTT, NE)
2149 DoubleLeOp -> (FCMP TF LE, NE)
2151 genCondJump lbl (StPrim op [x, y])
2152 = trivialCode instr x y `thenUs` \ register ->
2153 getNewRegNCG IntRep `thenUs` \ tmp ->
2155 code = registerCode register tmp
2156 result = registerName register tmp
2157 target = ImmCLbl lbl
2159 returnUs (code . mkSeqInstr (BI cond result target))
2161 (instr, cond) = case op of
2162 CharGtOp -> (CMP LE, EQQ)
2163 CharGeOp -> (CMP LTT, EQQ)
2164 CharEqOp -> (CMP EQQ, NE)
2165 CharNeOp -> (CMP EQQ, EQQ)
2166 CharLtOp -> (CMP LTT, NE)
2167 CharLeOp -> (CMP LE, NE)
2168 IntGtOp -> (CMP LE, EQQ)
2169 IntGeOp -> (CMP LTT, EQQ)
2170 IntEqOp -> (CMP EQQ, NE)
2171 IntNeOp -> (CMP EQQ, EQQ)
2172 IntLtOp -> (CMP LTT, NE)
2173 IntLeOp -> (CMP LE, NE)
2174 WordGtOp -> (CMP ULE, EQQ)
2175 WordGeOp -> (CMP ULT, EQQ)
2176 WordEqOp -> (CMP EQQ, NE)
2177 WordNeOp -> (CMP EQQ, EQQ)
2178 WordLtOp -> (CMP ULT, NE)
2179 WordLeOp -> (CMP ULE, NE)
2180 AddrGtOp -> (CMP ULE, EQQ)
2181 AddrGeOp -> (CMP ULT, EQQ)
2182 AddrEqOp -> (CMP EQQ, NE)
2183 AddrNeOp -> (CMP EQQ, EQQ)
2184 AddrLtOp -> (CMP ULT, NE)
2185 AddrLeOp -> (CMP ULE, NE)
2187 #endif {- alpha_TARGET_ARCH -}
2188 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2189 #if i386_TARGET_ARCH
2191 genCondJump lbl bool
2192 = getCondCode bool `thenUs` \ condition ->
2194 code = condCode condition
2195 cond = condName condition
2196 target = ImmCLbl lbl
2198 returnSeq code [JXX cond lbl]
2200 #endif {- i386_TARGET_ARCH -}
2201 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2202 #if sparc_TARGET_ARCH
2204 genCondJump lbl bool
2205 = getCondCode bool `thenUs` \ condition ->
2207 code = condCode condition
2208 cond = condName condition
2209 target = ImmCLbl lbl
2212 if condFloat condition then
2213 [NOP, BF cond False target, NOP]
2215 [BI cond False target, NOP]
2218 #endif {- sparc_TARGET_ARCH -}
2221 %************************************************************************
2223 \subsection{Generating C calls}
2225 %************************************************************************
2227 Now the biggest nightmare---calls. Most of the nastiness is buried in
2228 @get_arg@, which moves the arguments to the correct registers/stack
2229 locations. Apart from that, the code is easy.
2231 (If applicable) Do not fill the delay slots here; you will confuse the
2236 :: FAST_STRING -- function to call
2237 -> PrimRep -- type of the result
2238 -> [StixTree] -- arguments (of mixed type)
2239 -> UniqSM InstrBlock
2241 #if alpha_TARGET_ARCH
2243 genCCall fn kind args
2244 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2245 `thenUs` \ ((unused,_), argCode) ->
2247 nRegs = length allArgRegs - length unused
2248 code = asmParThen (map ($ asmVoid) argCode)
2251 LDA pv (AddrImm (ImmLab (ptext fn))),
2252 JSR ra (AddrReg pv) nRegs,
2253 LDGP gp (AddrReg ra)]
2255 ------------------------
2256 {- Try to get a value into a specific register (or registers) for
2257 a call. The first 6 arguments go into the appropriate
2258 argument register (separate registers for integer and floating
2259 point arguments, but used in lock-step), and the remaining
2260 arguments are dumped to the stack, beginning at 0(sp). Our
2261 first argument is a pair of the list of remaining argument
2262 registers to be assigned for this call and the next stack
2263 offset to use for overflowing arguments. This way,
2264 @get_Arg@ can be applied to all of a call's arguments using
2268 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2269 -> StixTree -- Current argument
2270 -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2272 -- We have to use up all of our argument registers first...
2274 get_arg ((iDst,fDst):dsts, offset) arg
2275 = getRegister arg `thenUs` \ register ->
2277 reg = if isFloatingRep pk then fDst else iDst
2278 code = registerCode register reg
2279 src = registerName register reg
2280 pk = registerRep register
2283 if isFloatingRep pk then
2284 ((dsts, offset), if isFixed register then
2285 code . mkSeqInstr (FMOV src fDst)
2288 ((dsts, offset), if isFixed register then
2289 code . mkSeqInstr (OR src (RIReg src) iDst)
2292 -- Once we have run out of argument registers, we move to the
2295 get_arg ([], offset) arg
2296 = getRegister arg `thenUs` \ register ->
2297 getNewRegNCG (registerRep register)
2300 code = registerCode register tmp
2301 src = registerName register tmp
2302 pk = registerRep register
2303 sz = primRepToSize pk
2305 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2307 #endif {- alpha_TARGET_ARCH -}
2308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2309 #if i386_TARGET_ARCH
2311 genCCall fn kind [StInt i]
2312 | fn == SLIT ("PerformGC_wrapper")
2314 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2315 CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2320 = getUniqLabelNCG `thenUs` \ lbl ->
2322 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2323 MOV L (OpImm (ImmCLbl lbl))
2324 -- this is hardwired
2325 (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
2326 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2332 genCCall fn kind args
2333 = mapUs get_call_arg args `thenUs` \ argCode ->
2337 {- OLD: Since there's no attempt at stealing %esp at the moment,
2338 restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
2339 (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2340 code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
2341 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2345 code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2346 call = [CALL fn__2 ,
2347 -- pop args; all args word sized?
2348 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2350 -- Don't restore %esp (see above)
2351 -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2354 returnSeq (code2) call
2356 -- function names that begin with '.' are assumed to be special
2357 -- internally generated names like '.mul,' which don't get an
2358 -- underscore prefix
2359 -- ToDo:needed (WDP 96/03) ???
2360 fn__2 = case (_HEAD_ fn) of
2361 '.' -> ImmLit (ptext fn)
2362 _ -> ImmLab (ptext fn)
2365 get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
2368 = get_op arg `thenUs` \ (code, op, sz) ->
2369 returnUs (code . mkSeqInstr (PUSH sz op))
2374 -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
2377 = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2379 get_op (StInd pk mem)
2380 = getAmode mem `thenUs` \ amode ->
2382 code = amodeCode amode --asmVoid
2383 addr = amodeAddr amode
2384 sz = primRepToSize pk
2386 returnUs (code, OpAddr addr, sz)
2389 = getRegister op `thenUs` \ register ->
2390 getNewRegNCG (registerRep register)
2393 code = registerCode register tmp
2394 reg = registerName register tmp
2395 pk = registerRep register
2396 sz = primRepToSize pk
2398 returnUs (code, OpReg reg, sz)
2400 #endif {- i386_TARGET_ARCH -}
2401 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2402 #if sparc_TARGET_ARCH
2404 genCCall fn kind args
2405 = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2406 `thenUs` \ ((unused,_), argCode) ->
2408 nRegs = length allArgRegs - length unused
2409 call = CALL fn__2 nRegs False
2410 code = asmParThen (map ($ asmVoid) argCode)
2412 returnSeq code [call, NOP]
2414 -- function names that begin with '.' are assumed to be special
2415 -- internally generated names like '.mul,' which don't get an
2416 -- underscore prefix
2417 -- ToDo:needed (WDP 96/03) ???
2418 fn__2 = case (_HEAD_ fn) of
2419 '.' -> ImmLit (ptext fn)
2420 _ -> ImmLab (ptext fn)
2422 ------------------------------------
2423 {- Try to get a value into a specific register (or registers) for
2424 a call. The SPARC calling convention is an absolute
2425 nightmare. The first 6x32 bits of arguments are mapped into
2426 %o0 through %o5, and the remaining arguments are dumped to the
2427 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2428 first argument is a pair of the list of remaining argument
2429 registers to be assigned for this call and the next stack
2430 offset to use for overflowing arguments. This way,
2431 @get_arg@ can be applied to all of a call's arguments using
2435 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2436 -> StixTree -- Current argument
2437 -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2439 -- We have to use up all of our argument registers first...
2441 get_arg (dst:dsts, offset) arg
2442 = getRegister arg `thenUs` \ register ->
2443 getNewRegNCG (registerRep register)
2446 reg = if isFloatingRep pk then tmp else dst
2447 code = registerCode register reg
2448 src = registerName register reg
2449 pk = registerRep register
2451 returnUs (case pk of
2454 [] -> (([], offset + 1), code . mkSeqInstrs [
2455 -- conveniently put the second part in the right stack
2456 -- location, and load the first part into %o5
2457 ST DF src (spRel (offset - 1)),
2458 LD W (spRel (offset - 1)) dst])
2459 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2460 ST DF src (spRel (-2)),
2461 LD W (spRel (-2)) dst,
2462 LD W (spRel (-1)) dst__2])
2463 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2464 ST F src (spRel (-2)),
2465 LD W (spRel (-2)) dst])
2466 _ -> ((dsts, offset), if isFixed register then
2467 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2470 -- Once we have run out of argument registers, we move to the
2473 get_arg ([], offset) arg
2474 = getRegister arg `thenUs` \ register ->
2475 getNewRegNCG (registerRep register)
2478 code = registerCode register tmp
2479 src = registerName register tmp
2480 pk = registerRep register
2481 sz = primRepToSize pk
2482 words = if pk == DoubleRep then 2 else 1
2484 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2486 #endif {- sparc_TARGET_ARCH -}
2489 %************************************************************************
2491 \subsection{Support bits}
2493 %************************************************************************
2495 %************************************************************************
2497 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2499 %************************************************************************
2501 Turn those condition codes into integers now (when they appear on
2502 the right hand side of an assignment).
2504 (If applicable) Do not fill the delay slots here; you will confuse the
2508 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2510 #if alpha_TARGET_ARCH
2511 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2512 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2513 #endif {- alpha_TARGET_ARCH -}
2515 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2516 #if i386_TARGET_ARCH
2519 = condIntCode cond x y `thenUs` \ condition ->
2520 getNewRegNCG IntRep `thenUs` \ tmp ->
2521 --getRegister dst `thenUs` \ register ->
2523 --code2 = registerCode register tmp asmVoid
2524 --dst__2 = registerName register tmp
2525 code = condCode condition
2526 cond = condName condition
2527 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2528 code__2 dst = code . mkSeqInstrs [
2529 SETCC cond (OpReg tmp),
2530 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2531 MOV L (OpReg tmp) (OpReg dst)]
2533 returnUs (Any IntRep code__2)
2536 = getUniqLabelNCG `thenUs` \ lbl1 ->
2537 getUniqLabelNCG `thenUs` \ lbl2 ->
2538 condFltCode cond x y `thenUs` \ condition ->
2540 code = condCode condition
2541 cond = condName condition
2542 code__2 dst = code . mkSeqInstrs [
2544 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2547 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2550 returnUs (Any IntRep code__2)
2552 #endif {- i386_TARGET_ARCH -}
2553 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2554 #if sparc_TARGET_ARCH
2556 condIntReg EQQ x (StInt 0)
2557 = getRegister x `thenUs` \ register ->
2558 getNewRegNCG IntRep `thenUs` \ tmp ->
2560 code = registerCode register tmp
2561 src = registerName register tmp
2562 code__2 dst = code . mkSeqInstrs [
2563 SUB False True g0 (RIReg src) g0,
2564 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2566 returnUs (Any IntRep code__2)
2569 = getRegister x `thenUs` \ register1 ->
2570 getRegister y `thenUs` \ register2 ->
2571 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2572 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2574 code1 = registerCode register1 tmp1 asmVoid
2575 src1 = registerName register1 tmp1
2576 code2 = registerCode register2 tmp2 asmVoid
2577 src2 = registerName register2 tmp2
2578 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2579 XOR False src1 (RIReg src2) dst,
2580 SUB False True g0 (RIReg dst) g0,
2581 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2583 returnUs (Any IntRep code__2)
2585 condIntReg NE x (StInt 0)
2586 = getRegister x `thenUs` \ register ->
2587 getNewRegNCG IntRep `thenUs` \ tmp ->
2589 code = registerCode register tmp
2590 src = registerName register tmp
2591 code__2 dst = code . mkSeqInstrs [
2592 SUB False True g0 (RIReg src) g0,
2593 ADD True False g0 (RIImm (ImmInt 0)) dst]
2595 returnUs (Any IntRep code__2)
2598 = getRegister x `thenUs` \ register1 ->
2599 getRegister y `thenUs` \ register2 ->
2600 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2601 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2603 code1 = registerCode register1 tmp1 asmVoid
2604 src1 = registerName register1 tmp1
2605 code2 = registerCode register2 tmp2 asmVoid
2606 src2 = registerName register2 tmp2
2607 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2608 XOR False src1 (RIReg src2) dst,
2609 SUB False True g0 (RIReg dst) g0,
2610 ADD True False g0 (RIImm (ImmInt 0)) dst]
2612 returnUs (Any IntRep code__2)
2615 = getUniqLabelNCG `thenUs` \ lbl1 ->
2616 getUniqLabelNCG `thenUs` \ lbl2 ->
2617 condIntCode cond x y `thenUs` \ condition ->
2619 code = condCode condition
2620 cond = condName condition
2621 code__2 dst = code . mkSeqInstrs [
2622 BI cond False (ImmCLbl lbl1), NOP,
2623 OR False g0 (RIImm (ImmInt 0)) dst,
2624 BI ALWAYS False (ImmCLbl lbl2), NOP,
2626 OR False g0 (RIImm (ImmInt 1)) dst,
2629 returnUs (Any IntRep code__2)
2632 = getUniqLabelNCG `thenUs` \ lbl1 ->
2633 getUniqLabelNCG `thenUs` \ lbl2 ->
2634 condFltCode cond x y `thenUs` \ condition ->
2636 code = condCode condition
2637 cond = condName condition
2638 code__2 dst = code . mkSeqInstrs [
2640 BF cond False (ImmCLbl lbl1), NOP,
2641 OR False g0 (RIImm (ImmInt 0)) dst,
2642 BI ALWAYS False (ImmCLbl lbl2), NOP,
2644 OR False g0 (RIImm (ImmInt 1)) dst,
2647 returnUs (Any IntRep code__2)
2649 #endif {- sparc_TARGET_ARCH -}
2652 %************************************************************************
2654 \subsubsection{@trivial*Code@: deal with trivial instructions}
2656 %************************************************************************
2658 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2659 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2660 for constants on the right hand side, because that's where the generic
2661 optimizer will have put them.
2663 Similarly, for unary instructions, we don't have to worry about
2664 matching an StInt as the argument, because genericOpt will already
2665 have handled the constant-folding.
2669 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2670 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2671 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2673 -> StixTree -> StixTree -- the two arguments
2678 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2679 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2681 {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2682 (Size -> Operand -> Instr)
2683 -> (Size -> Operand -> Instr) {-reversed instr-}
2685 -> Instr {-reversed instr: pop-}
2687 -> StixTree -> StixTree -- the two arguments
2691 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2692 ,IF_ARCH_i386 ((Operand -> Instr)
2693 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2695 -> StixTree -- the one argument
2700 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2701 ,IF_ARCH_i386 (Instr
2702 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2704 -> StixTree -- the one argument
2707 #if alpha_TARGET_ARCH
2709 trivialCode instr x (StInt y)
2711 = getRegister x `thenUs` \ register ->
2712 getNewRegNCG IntRep `thenUs` \ tmp ->
2714 code = registerCode register tmp
2715 src1 = registerName register tmp
2716 src2 = ImmInt (fromInteger y)
2717 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2719 returnUs (Any IntRep code__2)
2721 trivialCode instr x y
2722 = getRegister x `thenUs` \ register1 ->
2723 getRegister y `thenUs` \ register2 ->
2724 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2725 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2727 code1 = registerCode register1 tmp1 asmVoid
2728 src1 = registerName register1 tmp1
2729 code2 = registerCode register2 tmp2 asmVoid
2730 src2 = registerName register2 tmp2
2731 code__2 dst = asmParThen [code1, code2] .
2732 mkSeqInstr (instr src1 (RIReg src2) dst)
2734 returnUs (Any IntRep code__2)
2737 trivialUCode instr x
2738 = getRegister x `thenUs` \ register ->
2739 getNewRegNCG IntRep `thenUs` \ tmp ->
2741 code = registerCode register tmp
2742 src = registerName register tmp
2743 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2745 returnUs (Any IntRep code__2)
2748 trivialFCode _ instr x y
2749 = getRegister x `thenUs` \ register1 ->
2750 getRegister y `thenUs` \ register2 ->
2751 getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
2752 getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
2754 code1 = registerCode register1 tmp1
2755 src1 = registerName register1 tmp1
2757 code2 = registerCode register2 tmp2
2758 src2 = registerName register2 tmp2
2760 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2761 mkSeqInstr (instr src1 src2 dst)
2763 returnUs (Any DoubleRep code__2)
2765 trivialUFCode _ instr x
2766 = getRegister x `thenUs` \ register ->
2767 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2769 code = registerCode register tmp
2770 src = registerName register tmp
2771 code__2 dst = code . mkSeqInstr (instr src dst)
2773 returnUs (Any DoubleRep code__2)
2775 #endif {- alpha_TARGET_ARCH -}
2776 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2777 #if i386_TARGET_ARCH
2779 trivialCode instr x y
2781 = getRegister x `thenUs` \ register1 ->
2782 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2784 -- fixedname = registerName register1 eax
2785 code__2 dst = let code1 = registerCode register1 dst
2786 src1 = registerName register1 dst
2788 if isFixed register1 && src1 /= dst
2789 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2790 instr (OpImm imm__2) (OpReg dst)]
2792 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2794 returnUs (Any IntRep code__2)
2797 imm__2 = case imm of Just x -> x
2799 trivialCode instr x y
2801 = getRegister y `thenUs` \ register1 ->
2802 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2804 -- fixedname = registerName register1 eax
2805 code__2 dst = let code1 = registerCode register1 dst
2806 src1 = registerName register1 dst
2808 if isFixed register1 && src1 /= dst
2809 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2810 instr (OpImm imm__2) (OpReg dst)]
2812 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2814 returnUs (Any IntRep code__2)
2817 imm__2 = case imm of Just x -> x
2819 trivialCode instr x (StInd pk mem)
2820 = getRegister x `thenUs` \ register ->
2821 --getNewRegNCG IntRep `thenUs` \ tmp ->
2822 getAmode mem `thenUs` \ amode ->
2824 -- fixedname = registerName register eax
2825 code2 = amodeCode amode asmVoid
2826 src2 = amodeAddr amode
2827 code__2 dst = let code1 = registerCode register dst asmVoid
2828 src1 = registerName register dst
2829 in asmParThen [code1, code2] .
2830 if isFixed register && src1 /= dst
2831 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2832 instr (OpAddr src2) (OpReg dst)]
2834 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2836 returnUs (Any pk code__2)
2838 trivialCode instr (StInd pk mem) y
2839 = getRegister y `thenUs` \ register ->
2840 --getNewRegNCG IntRep `thenUs` \ tmp ->
2841 getAmode mem `thenUs` \ amode ->
2843 -- fixedname = registerName register eax
2844 code2 = amodeCode amode asmVoid
2845 src2 = amodeAddr amode
2847 code1 = registerCode register dst asmVoid
2848 src1 = registerName register dst
2849 in asmParThen [code1, code2] .
2850 if isFixed register && src1 /= dst
2851 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2852 instr (OpAddr src2) (OpReg dst)]
2854 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2856 returnUs (Any pk code__2)
2858 trivialCode instr x y
2859 = getRegister x `thenUs` \ register1 ->
2860 getRegister y `thenUs` \ register2 ->
2861 --getNewRegNCG IntRep `thenUs` \ tmp1 ->
2862 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2864 -- fixedname = registerName register1 eax
2865 code2 = registerCode register2 tmp2 asmVoid
2866 src2 = registerName register2 tmp2
2868 code1 = registerCode register1 dst asmVoid
2869 src1 = registerName register1 dst
2870 in asmParThen [code1, code2] .
2871 if isFixed register1 && src1 /= dst
2872 then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2873 instr (OpReg src2) (OpReg dst)]
2875 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2877 returnUs (Any IntRep code__2)
2880 trivialUCode instr x
2881 = getRegister x `thenUs` \ register ->
2882 -- getNewRegNCG IntRep `thenUs` \ tmp ->
2884 -- fixedname = registerName register eax
2886 code = registerCode register dst
2887 src = registerName register dst
2888 in code . if isFixed register && dst /= src
2889 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2891 else mkSeqInstr (instr (OpReg src))
2893 returnUs (Any IntRep code__2)
2896 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2897 = getRegister y `thenUs` \ register2 ->
2898 --getNewRegNCG (registerRep register2)
2899 -- `thenUs` \ tmp2 ->
2900 getAmode mem `thenUs` \ amode ->
2902 code1 = amodeCode amode
2903 src1 = amodeAddr amode
2906 code2 = registerCode register2 dst
2907 src2 = registerName register2 dst
2908 in asmParThen [code1 asmVoid,code2 asmVoid] .
2909 mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2911 returnUs (Any pk code__2)
2913 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2914 = getRegister x `thenUs` \ register1 ->
2915 --getNewRegNCG (registerRep register1)
2916 -- `thenUs` \ tmp1 ->
2917 getAmode mem `thenUs` \ amode ->
2919 code2 = amodeCode amode
2920 src2 = amodeAddr amode
2923 code1 = registerCode register1 dst
2924 src1 = registerName register1 dst
2925 in asmParThen [code2 asmVoid,code1 asmVoid] .
2926 mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2928 returnUs (Any pk code__2)
2930 trivialFCode pk _ _ _ instrpr x y
2931 = getRegister x `thenUs` \ register1 ->
2932 getRegister y `thenUs` \ register2 ->
2933 --getNewRegNCG (registerRep register1)
2934 -- `thenUs` \ tmp1 ->
2935 --getNewRegNCG (registerRep register2)
2936 -- `thenUs` \ tmp2 ->
2937 getNewRegNCG DoubleRep `thenUs` \ tmp ->
2939 pk1 = registerRep register1
2940 code1 = registerCode register1 st0 --tmp1
2941 src1 = registerName register1 st0 --tmp1
2943 pk2 = registerRep register2
2946 code2 = registerCode register2 dst
2947 src2 = registerName register2 dst
2948 in asmParThen [code1 asmVoid, code2 asmVoid] .
2951 returnUs (Any pk1 code__2)
2954 trivialUFCode pk instr (StInd pk' mem)
2955 = getAmode mem `thenUs` \ amode ->
2957 code = amodeCode amode
2958 src = amodeAddr amode
2959 code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2962 returnUs (Any pk code__2)
2964 trivialUFCode pk instr x
2965 = getRegister x `thenUs` \ register ->
2966 --getNewRegNCG pk `thenUs` \ tmp ->
2969 code = registerCode register dst
2970 src = registerName register dst
2971 in code . mkSeqInstrs [instr]
2973 returnUs (Any pk code__2)
2975 #endif {- i386_TARGET_ARCH -}
2976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2977 #if sparc_TARGET_ARCH
2979 trivialCode instr x (StInt y)
2981 = getRegister x `thenUs` \ register ->
2982 getNewRegNCG IntRep `thenUs` \ tmp ->
2984 code = registerCode register tmp
2985 src1 = registerName register tmp
2986 src2 = ImmInt (fromInteger y)
2987 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2989 returnUs (Any IntRep code__2)
2991 trivialCode instr x y
2992 = getRegister x `thenUs` \ register1 ->
2993 getRegister y `thenUs` \ register2 ->
2994 getNewRegNCG IntRep `thenUs` \ tmp1 ->
2995 getNewRegNCG IntRep `thenUs` \ tmp2 ->
2997 code1 = registerCode register1 tmp1 asmVoid
2998 src1 = registerName register1 tmp1
2999 code2 = registerCode register2 tmp2 asmVoid
3000 src2 = registerName register2 tmp2
3001 code__2 dst = asmParThen [code1, code2] .
3002 mkSeqInstr (instr src1 (RIReg src2) dst)
3004 returnUs (Any IntRep code__2)
3007 trivialFCode pk instr x y
3008 = getRegister x `thenUs` \ register1 ->
3009 getRegister y `thenUs` \ register2 ->
3010 getNewRegNCG (registerRep register1)
3012 getNewRegNCG (registerRep register2)
3014 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3016 promote x = asmInstr (FxTOy F DF x tmp)
3018 pk1 = registerRep register1
3019 code1 = registerCode register1 tmp1
3020 src1 = registerName register1 tmp1
3022 pk2 = registerRep register2
3023 code2 = registerCode register2 tmp2
3024 src2 = registerName register2 tmp2
3028 asmParThen [code1 asmVoid, code2 asmVoid] .
3029 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3030 else if pk1 == FloatRep then
3031 asmParThen [code1 (promote src1), code2 asmVoid] .
3032 mkSeqInstr (instr DF tmp src2 dst)
3034 asmParThen [code1 asmVoid, code2 (promote src2)] .
3035 mkSeqInstr (instr DF src1 tmp dst)
3037 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3040 trivialUCode instr x
3041 = getRegister x `thenUs` \ register ->
3042 getNewRegNCG IntRep `thenUs` \ tmp ->
3044 code = registerCode register tmp
3045 src = registerName register tmp
3046 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3048 returnUs (Any IntRep code__2)
3051 trivialUFCode pk instr x
3052 = getRegister x `thenUs` \ register ->
3053 getNewRegNCG pk `thenUs` \ tmp ->
3055 code = registerCode register tmp
3056 src = registerName register tmp
3057 code__2 dst = code . mkSeqInstr (instr src dst)
3059 returnUs (Any pk code__2)
3061 #endif {- sparc_TARGET_ARCH -}
3064 %************************************************************************
3066 \subsubsection{Coercing to/from integer/floating-point...}
3068 %************************************************************************
3070 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3071 to be generated. Here we just change the type on the Register passed
3072 on up. The code is machine-independent.
3074 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3075 conversions. We have to store temporaries in memory to move
3076 between the integer and the floating point register sets.
3079 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3080 coerceFltCode :: StixTree -> UniqSM Register
3082 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3083 coerceFP2Int :: StixTree -> UniqSM Register
3086 = getRegister x `thenUs` \ register ->
3089 Fixed _ reg code -> Fixed pk reg code
3090 Any _ code -> Any pk code
3095 = getRegister x `thenUs` \ register ->
3098 Fixed _ reg code -> Fixed DoubleRep reg code
3099 Any _ code -> Any DoubleRep code
3104 #if alpha_TARGET_ARCH
3107 = getRegister x `thenUs` \ register ->
3108 getNewRegNCG IntRep `thenUs` \ reg ->
3110 code = registerCode register reg
3111 src = registerName register reg
3113 code__2 dst = code . mkSeqInstrs [
3115 LD TF dst (spRel 0),
3118 returnUs (Any DoubleRep code__2)
3122 = getRegister x `thenUs` \ register ->
3123 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3125 code = registerCode register tmp
3126 src = registerName register tmp
3128 code__2 dst = code . mkSeqInstrs [
3130 ST TF tmp (spRel 0),
3133 returnUs (Any IntRep code__2)
3135 #endif {- alpha_TARGET_ARCH -}
3136 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3137 #if i386_TARGET_ARCH
3140 = getRegister x `thenUs` \ register ->
3141 getNewRegNCG IntRep `thenUs` \ reg ->
3143 code = registerCode register reg
3144 src = registerName register reg
3146 code__2 dst = code . mkSeqInstrs [
3147 -- to fix: should spill instead of using R1
3148 MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3149 FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3151 returnUs (Any pk code__2)
3155 = getRegister x `thenUs` \ register ->
3156 getNewRegNCG DoubleRep `thenUs` \ tmp ->
3158 code = registerCode register tmp
3159 src = registerName register tmp
3160 pk = registerRep register
3162 code__2 dst = code . mkSeqInstrs [
3164 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3165 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3167 returnUs (Any IntRep code__2)
3169 #endif {- i386_TARGET_ARCH -}
3170 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3171 #if sparc_TARGET_ARCH
3174 = getRegister x `thenUs` \ register ->
3175 getNewRegNCG IntRep `thenUs` \ reg ->
3177 code = registerCode register reg
3178 src = registerName register reg
3180 code__2 dst = code . mkSeqInstrs [
3181 ST W src (spRel (-2)),
3182 LD W (spRel (-2)) dst,
3183 FxTOy W (primRepToSize pk) dst dst]
3185 returnUs (Any pk code__2)
3189 = getRegister x `thenUs` \ register ->
3190 getNewRegNCG IntRep `thenUs` \ reg ->
3191 getNewRegNCG FloatRep `thenUs` \ tmp ->
3193 code = registerCode register reg
3194 src = registerName register reg
3195 pk = registerRep register
3197 code__2 dst = code . mkSeqInstrs [
3198 FxTOy (primRepToSize pk) W src tmp,
3199 ST W tmp (spRel (-2)),
3200 LD W (spRel (-2)) dst]
3202 returnUs (Any IntRep code__2)
3204 #endif {- sparc_TARGET_ARCH -}
3207 %************************************************************************
3209 \subsubsection{Coercing integer to @Char@...}
3211 %************************************************************************
3213 Integer to character conversion. Where applicable, we try to do this
3214 in one step if the original object is in memory.
3217 chrCode :: StixTree -> UniqSM Register
3219 #if alpha_TARGET_ARCH
3222 = getRegister x `thenUs` \ register ->
3223 getNewRegNCG IntRep `thenUs` \ reg ->
3225 code = registerCode register reg
3226 src = registerName register reg
3227 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3229 returnUs (Any IntRep code__2)
3231 #endif {- alpha_TARGET_ARCH -}
3232 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3233 #if i386_TARGET_ARCH
3236 = getRegister x `thenUs` \ register ->
3237 --getNewRegNCG IntRep `thenUs` \ reg ->
3239 -- fixedname = registerName register eax
3241 code = registerCode register dst
3242 src = registerName register dst
3244 if isFixed register && src /= dst
3245 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3246 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3247 else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3249 returnUs (Any IntRep code__2)
3251 #endif {- i386_TARGET_ARCH -}
3252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3253 #if sparc_TARGET_ARCH
3255 chrCode (StInd pk mem)
3256 = getAmode mem `thenUs` \ amode ->
3258 code = amodeCode amode
3259 src = amodeAddr amode
3260 src_off = addrOffset src 3
3261 src__2 = case src_off of Just x -> x
3262 code__2 dst = if maybeToBool src_off then
3263 code . mkSeqInstr (LD BU src__2 dst)
3265 code . mkSeqInstrs [
3266 LD (primRepToSize pk) src dst,
3267 AND False dst (RIImm (ImmInt 255)) dst]
3269 returnUs (Any pk code__2)
3272 = getRegister x `thenUs` \ register ->
3273 getNewRegNCG IntRep `thenUs` \ reg ->
3275 code = registerCode register reg
3276 src = registerName register reg
3277 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3279 returnUs (Any IntRep code__2)
3281 #endif {- sparc_TARGET_ARCH -}
3284 %************************************************************************
3286 \subsubsection{Absolute value on integers}
3288 %************************************************************************
3290 Absolute value on integers, mostly for gmp size check macros. Again,
3291 the argument cannot be an StInt, because genericOpt already folded
3294 If applicable, do not fill the delay slots here; you will confuse the
3298 absIntCode :: StixTree -> UniqSM Register
3300 #if alpha_TARGET_ARCH
3301 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3302 #endif {- alpha_TARGET_ARCH -}
3304 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3305 #if i386_TARGET_ARCH
3308 = getRegister x `thenUs` \ register ->
3309 --getNewRegNCG IntRep `thenUs` \ reg ->
3310 getUniqLabelNCG `thenUs` \ lbl ->
3312 code__2 dst = let code = registerCode register dst
3313 src = registerName register dst
3314 in code . if isFixed register && dst /= src
3315 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3316 TEST L (OpReg dst) (OpReg dst),
3320 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3325 returnUs (Any IntRep code__2)
3327 #endif {- i386_TARGET_ARCH -}
3328 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3329 #if sparc_TARGET_ARCH
3332 = getRegister x `thenUs` \ register ->
3333 getNewRegNCG IntRep `thenUs` \ reg ->
3334 getUniqLabelNCG `thenUs` \ lbl ->
3336 code = registerCode register reg
3337 src = registerName register reg
3338 code__2 dst = code . mkSeqInstrs [
3339 SUB False True g0 (RIReg src) dst,
3340 BI GE False (ImmCLbl lbl), NOP,
3341 OR False g0 (RIReg src) dst,
3344 returnUs (Any IntRep code__2)
3346 #endif {- sparc_TARGET_ARCH -}