2 % (c) The AQUA Project, Glasgow University, 1996-1998
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, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv, stdCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 DestInfo, hasDestInfo,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
61 stmt2Instrs stmt = case stmt of
62 StComment s -> returnNat (unitOL (COMMENT s))
63 StSegment seg -> returnNat (unitOL (SEGMENT seg))
65 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
67 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
70 StLabel lab -> returnNat (unitOL (LABEL lab))
72 StJump dsts arg -> genJump dsts (derefDLL arg)
73 StCondJump lab arg -> genCondJump lab (derefDLL arg)
75 -- A call returning void, ie one done for its side-effects
76 StCall fn cconv VoidRep args -> genCCall fn
77 cconv VoidRep (map derefDLL args)
80 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
81 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
84 -- When falling through on the Alpha, we still have to load pv
85 -- with the address of the next routine, so that it can load gp.
86 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
90 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
91 returnNat (DATA (primRepToSize kind) imms
92 `consOL` concatOL codes)
94 getData :: StixTree -> NatM (InstrBlock, Imm)
96 getData (StInt i) = returnNat (nilOL, ImmInteger i)
97 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
98 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
99 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
100 getData (StString s) =
101 getNatLabelNCG `thenNat` \ lbl ->
102 returnNat (toOL [LABEL lbl,
103 ASCII True (_UNPK_ s)],
105 -- the linker can handle simple arithmetic...
106 getData (StIndex rep (StCLbl lbl) (StInt off)) =
108 ImmIndex lbl (fromInteger (off * sizeOf rep)))
110 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
111 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
112 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
114 derefDLL :: StixTree -> StixTree
116 | opt_Static -- short out the entire deal if not doing DLLs
123 StCLbl lbl -> if labelDynamic lbl
124 then StInd PtrRep (StCLbl lbl)
126 -- all the rest are boring
127 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
128 StPrim pk args -> StPrim pk (map qq args)
129 StInd pk addr -> StInd pk (qq addr)
130 StCall who cc pk args -> StCall who cc pk (map qq args)
137 _ -> pprPanic "derefDLL: unhandled case"
141 %************************************************************************
143 \subsection{General things for putting together code sequences}
145 %************************************************************************
148 mangleIndexTree :: StixTree -> StixTree
150 mangleIndexTree (StIndex pk base (StInt i))
151 = StPrim IntAddOp [base, off]
153 off = StInt (i * sizeOf pk)
155 mangleIndexTree (StIndex pk base off)
159 in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
162 shift :: PrimRep -> Int
163 shift rep = case (fromInteger (sizeOf rep) :: Int) of
168 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
173 maybeImm :: StixTree -> Maybe Imm
177 maybeImm (StIndex rep (StCLbl l) (StInt off))
178 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
180 | i >= toInteger minInt && i <= toInteger maxInt
181 = Just (ImmInt (fromInteger i))
183 = Just (ImmInteger i)
188 %************************************************************************
190 \subsection{The @Register@ type}
192 %************************************************************************
194 @Register@s passed up the tree. If the stix code forces the register
195 to live in a pre-decided machine register, it comes out as @Fixed@;
196 otherwise, it comes out as @Any@, and the parent can decide which
197 register to put it in.
201 = Fixed PrimRep Reg InstrBlock
202 | Any PrimRep (Reg -> InstrBlock)
204 registerCode :: Register -> Reg -> InstrBlock
205 registerCode (Fixed _ _ code) reg = code
206 registerCode (Any _ code) reg = code reg
208 registerCodeF (Fixed _ _ code) = code
209 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
211 registerCodeA (Any _ code) = code
212 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
214 registerName :: Register -> Reg -> Reg
215 registerName (Fixed _ reg _) _ = reg
216 registerName (Any _ _) reg = reg
218 registerNameF (Fixed _ reg _) = reg
219 registerNameF (Any _ _) = pprPanic "registerNameF" empty
221 registerRep :: Register -> PrimRep
222 registerRep (Fixed pk _ _) = pk
223 registerRep (Any pk _) = pk
225 {-# INLINE registerCode #-}
226 {-# INLINE registerCodeF #-}
227 {-# INLINE registerName #-}
228 {-# INLINE registerNameF #-}
229 {-# INLINE registerRep #-}
230 {-# INLINE isFixed #-}
233 isFixed, isAny :: Register -> Bool
234 isFixed (Fixed _ _ _) = True
235 isFixed (Any _ _) = False
237 isAny = not . isFixed
240 Generate code to get a subtree into a @Register@:
242 getRegister :: StixTree -> NatM Register
244 getRegister (StReg (StixMagicId stgreg))
245 = case (magicIdRegMaybe stgreg) of
246 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
249 getRegister (StReg (StixTemp u pk))
250 = returnNat (Fixed pk (mkVReg u pk) nilOL)
252 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
254 getRegister (StCall fn cconv kind args)
255 = genCCall fn cconv kind args `thenNat` \ call ->
256 returnNat (Fixed kind reg call)
258 reg = if isFloatingRep kind
259 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
260 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
262 getRegister (StString s)
263 = getNatLabelNCG `thenNat` \ lbl ->
265 imm_lbl = ImmCLbl lbl
268 SEGMENT RoDataSegment,
270 ASCII True (_UNPK_ s),
272 #if alpha_TARGET_ARCH
273 LDA dst (AddrImm imm_lbl)
276 MOV L (OpImm imm_lbl) (OpReg dst)
278 #if sparc_TARGET_ARCH
279 SETHI (HI imm_lbl) dst,
280 OR False dst (RIImm (LO imm_lbl)) dst
284 returnNat (Any PtrRep code)
288 -- end of machine-"independent" bit; here we go on the rest...
290 #if alpha_TARGET_ARCH
292 getRegister (StDouble d)
293 = getNatLabelNCG `thenNat` \ lbl ->
294 getNewRegNCG PtrRep `thenNat` \ tmp ->
295 let code dst = mkSeqInstrs [
298 DATA TF [ImmLab (rational d)],
300 LDA tmp (AddrImm (ImmCLbl lbl)),
301 LD TF dst (AddrReg tmp)]
303 returnNat (Any DoubleRep code)
305 getRegister (StPrim primop [x]) -- unary PrimOps
307 IntNegOp -> trivialUCode (NEG Q False) x
309 NotOp -> trivialUCode NOT x
311 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
312 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
314 OrdOp -> coerceIntCode IntRep x
317 Float2IntOp -> coerceFP2Int x
318 Int2FloatOp -> coerceInt2FP pr x
319 Double2IntOp -> coerceFP2Int x
320 Int2DoubleOp -> coerceInt2FP pr x
322 Double2FloatOp -> coerceFltCode x
323 Float2DoubleOp -> coerceFltCode x
325 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
327 fn = case other_op of
328 FloatExpOp -> SLIT("exp")
329 FloatLogOp -> SLIT("log")
330 FloatSqrtOp -> SLIT("sqrt")
331 FloatSinOp -> SLIT("sin")
332 FloatCosOp -> SLIT("cos")
333 FloatTanOp -> SLIT("tan")
334 FloatAsinOp -> SLIT("asin")
335 FloatAcosOp -> SLIT("acos")
336 FloatAtanOp -> SLIT("atan")
337 FloatSinhOp -> SLIT("sinh")
338 FloatCoshOp -> SLIT("cosh")
339 FloatTanhOp -> SLIT("tanh")
340 DoubleExpOp -> SLIT("exp")
341 DoubleLogOp -> SLIT("log")
342 DoubleSqrtOp -> SLIT("sqrt")
343 DoubleSinOp -> SLIT("sin")
344 DoubleCosOp -> SLIT("cos")
345 DoubleTanOp -> SLIT("tan")
346 DoubleAsinOp -> SLIT("asin")
347 DoubleAcosOp -> SLIT("acos")
348 DoubleAtanOp -> SLIT("atan")
349 DoubleSinhOp -> SLIT("sinh")
350 DoubleCoshOp -> SLIT("cosh")
351 DoubleTanhOp -> SLIT("tanh")
353 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
355 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
357 CharGtOp -> trivialCode (CMP LTT) y x
358 CharGeOp -> trivialCode (CMP LE) y x
359 CharEqOp -> trivialCode (CMP EQQ) x y
360 CharNeOp -> int_NE_code x y
361 CharLtOp -> trivialCode (CMP LTT) x y
362 CharLeOp -> trivialCode (CMP LE) x y
364 IntGtOp -> trivialCode (CMP LTT) y x
365 IntGeOp -> trivialCode (CMP LE) y x
366 IntEqOp -> trivialCode (CMP EQQ) x y
367 IntNeOp -> int_NE_code x y
368 IntLtOp -> trivialCode (CMP LTT) x y
369 IntLeOp -> trivialCode (CMP LE) x y
371 WordGtOp -> trivialCode (CMP ULT) y x
372 WordGeOp -> trivialCode (CMP ULE) x y
373 WordEqOp -> trivialCode (CMP EQQ) x y
374 WordNeOp -> int_NE_code x y
375 WordLtOp -> trivialCode (CMP ULT) x y
376 WordLeOp -> trivialCode (CMP ULE) x y
378 AddrGtOp -> trivialCode (CMP ULT) y x
379 AddrGeOp -> trivialCode (CMP ULE) y x
380 AddrEqOp -> trivialCode (CMP EQQ) x y
381 AddrNeOp -> int_NE_code x y
382 AddrLtOp -> trivialCode (CMP ULT) x y
383 AddrLeOp -> trivialCode (CMP ULE) x y
385 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
386 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
387 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
388 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
389 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
390 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
392 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
393 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
394 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
395 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
396 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
397 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
399 IntAddOp -> trivialCode (ADD Q False) x y
400 IntSubOp -> trivialCode (SUB Q False) x y
401 IntMulOp -> trivialCode (MUL Q False) x y
402 IntQuotOp -> trivialCode (DIV Q False) x y
403 IntRemOp -> trivialCode (REM Q False) x y
405 WordQuotOp -> trivialCode (DIV Q True) x y
406 WordRemOp -> trivialCode (REM Q True) x y
408 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
409 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
410 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
411 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
413 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
414 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
415 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
416 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
418 AndOp -> trivialCode AND x y
419 OrOp -> trivialCode OR x y
420 XorOp -> trivialCode XOR x y
421 SllOp -> trivialCode SLL x y
422 SrlOp -> trivialCode SRL x y
424 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
425 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
426 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
428 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
429 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
431 {- ------------------------------------------------------------
432 Some bizarre special code for getting condition codes into
433 registers. Integer non-equality is a test for equality
434 followed by an XOR with 1. (Integer comparisons always set
435 the result register to 0 or 1.) Floating point comparisons of
436 any kind leave the result in a floating point register, so we
437 need to wrangle an integer register out of things.
439 int_NE_code :: StixTree -> StixTree -> NatM Register
442 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
443 getNewRegNCG IntRep `thenNat` \ tmp ->
445 code = registerCode register tmp
446 src = registerName register tmp
447 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
449 returnNat (Any IntRep code__2)
451 {- ------------------------------------------------------------
452 Comments for int_NE_code also apply to cmpF_code
455 :: (Reg -> Reg -> Reg -> Instr)
457 -> StixTree -> StixTree
460 cmpF_code instr cond x y
461 = trivialFCode pr instr x y `thenNat` \ register ->
462 getNewRegNCG DoubleRep `thenNat` \ tmp ->
463 getNatLabelNCG `thenNat` \ lbl ->
465 code = registerCode register tmp
466 result = registerName register tmp
468 code__2 dst = code . mkSeqInstrs [
469 OR zeroh (RIImm (ImmInt 1)) dst,
470 BF cond result (ImmCLbl lbl),
471 OR zeroh (RIReg zeroh) dst,
474 returnNat (Any IntRep code__2)
476 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
477 ------------------------------------------------------------
479 getRegister (StInd pk mem)
480 = getAmode mem `thenNat` \ amode ->
482 code = amodeCode amode
483 src = amodeAddr amode
484 size = primRepToSize pk
485 code__2 dst = code . mkSeqInstr (LD size dst src)
487 returnNat (Any pk code__2)
489 getRegister (StInt i)
492 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
494 returnNat (Any IntRep code)
497 code dst = mkSeqInstr (LDI Q dst src)
499 returnNat (Any IntRep code)
501 src = ImmInt (fromInteger i)
506 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
508 returnNat (Any PtrRep code)
511 imm__2 = case imm of Just x -> x
513 #endif {- alpha_TARGET_ARCH -}
514 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
517 getRegister (StFloat f)
518 = getNatLabelNCG `thenNat` \ lbl ->
519 let code dst = toOL [
524 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
527 returnNat (Any FloatRep code)
530 getRegister (StDouble d)
533 = let code dst = unitOL (GLDZ dst)
534 in returnNat (Any DoubleRep code)
537 = let code dst = unitOL (GLD1 dst)
538 in returnNat (Any DoubleRep code)
541 = getNatLabelNCG `thenNat` \ lbl ->
542 let code dst = toOL [
545 DATA DF [ImmDouble d],
547 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
550 returnNat (Any DoubleRep code)
552 -- Calculate the offset for (i+1) words above the _initial_
553 -- %esp value by first determining the current offset of it.
554 getRegister (StScratchWord i)
556 = getDeltaNat `thenNat` \ current_stack_offset ->
557 let j = i+1 - (current_stack_offset `div` 4)
559 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
561 returnNat (Any PtrRep code)
563 getRegister (StPrim primop [x]) -- unary PrimOps
565 IntNegOp -> trivialUCode (NEGI L) x
566 NotOp -> trivialUCode (NOT L) x
568 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
569 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
571 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
572 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
574 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
575 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
577 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
578 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
580 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
581 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
583 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
584 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
586 OrdOp -> coerceIntCode IntRep x
589 Float2IntOp -> coerceFP2Int x
590 Int2FloatOp -> coerceInt2FP FloatRep x
591 Double2IntOp -> coerceFP2Int x
592 Int2DoubleOp -> coerceInt2FP DoubleRep x
595 getRegister (StCall fn cCallConv DoubleRep [x])
599 FloatExpOp -> (True, SLIT("exp"))
600 FloatLogOp -> (True, SLIT("log"))
602 FloatAsinOp -> (True, SLIT("asin"))
603 FloatAcosOp -> (True, SLIT("acos"))
604 FloatAtanOp -> (True, SLIT("atan"))
606 FloatSinhOp -> (True, SLIT("sinh"))
607 FloatCoshOp -> (True, SLIT("cosh"))
608 FloatTanhOp -> (True, SLIT("tanh"))
610 DoubleExpOp -> (False, SLIT("exp"))
611 DoubleLogOp -> (False, SLIT("log"))
613 DoubleAsinOp -> (False, SLIT("asin"))
614 DoubleAcosOp -> (False, SLIT("acos"))
615 DoubleAtanOp -> (False, SLIT("atan"))
617 DoubleSinhOp -> (False, SLIT("sinh"))
618 DoubleCoshOp -> (False, SLIT("cosh"))
619 DoubleTanhOp -> (False, SLIT("tanh"))
622 -> pprPanic "getRegister(x86,unary primop)"
623 (pprStixTree (StPrim primop [x]))
625 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
627 CharGtOp -> condIntReg GTT x y
628 CharGeOp -> condIntReg GE x y
629 CharEqOp -> condIntReg EQQ x y
630 CharNeOp -> condIntReg NE x y
631 CharLtOp -> condIntReg LTT x y
632 CharLeOp -> condIntReg LE x y
634 IntGtOp -> condIntReg GTT x y
635 IntGeOp -> condIntReg GE x y
636 IntEqOp -> condIntReg EQQ x y
637 IntNeOp -> condIntReg NE x y
638 IntLtOp -> condIntReg LTT x y
639 IntLeOp -> condIntReg LE x y
641 WordGtOp -> condIntReg GU x y
642 WordGeOp -> condIntReg GEU x y
643 WordEqOp -> condIntReg EQQ x y
644 WordNeOp -> condIntReg NE x y
645 WordLtOp -> condIntReg LU x y
646 WordLeOp -> condIntReg LEU x y
648 AddrGtOp -> condIntReg GU x y
649 AddrGeOp -> condIntReg GEU x y
650 AddrEqOp -> condIntReg EQQ x y
651 AddrNeOp -> condIntReg NE x y
652 AddrLtOp -> condIntReg LU x y
653 AddrLeOp -> condIntReg LEU x y
655 FloatGtOp -> condFltReg GTT x y
656 FloatGeOp -> condFltReg GE x y
657 FloatEqOp -> condFltReg EQQ x y
658 FloatNeOp -> condFltReg NE x y
659 FloatLtOp -> condFltReg LTT x y
660 FloatLeOp -> condFltReg LE x y
662 DoubleGtOp -> condFltReg GTT x y
663 DoubleGeOp -> condFltReg GE x y
664 DoubleEqOp -> condFltReg EQQ x y
665 DoubleNeOp -> condFltReg NE x y
666 DoubleLtOp -> condFltReg LTT x y
667 DoubleLeOp -> condFltReg LE x y
669 IntAddOp -> add_code L x y
670 IntSubOp -> sub_code L x y
671 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
672 IntRemOp -> trivialCode (IREM L) Nothing x y
673 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
675 FloatAddOp -> trivialFCode FloatRep GADD x y
676 FloatSubOp -> trivialFCode FloatRep GSUB x y
677 FloatMulOp -> trivialFCode FloatRep GMUL x y
678 FloatDivOp -> trivialFCode FloatRep GDIV x y
680 DoubleAddOp -> trivialFCode DoubleRep GADD x y
681 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
682 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
683 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
685 AndOp -> let op = AND L in trivialCode op (Just op) x y
686 OrOp -> let op = OR L in trivialCode op (Just op) x y
687 XorOp -> let op = XOR L in trivialCode op (Just op) x y
689 {- Shift ops on x86s have constraints on their source, it
690 either has to be Imm, CL or 1
691 => trivialCode's is not restrictive enough (sigh.)
694 SllOp -> shift_code (SHL L) x y {-False-}
695 SrlOp -> shift_code (SHR L) x y {-False-}
696 ISllOp -> shift_code (SHL L) x y {-False-}
697 ISraOp -> shift_code (SAR L) x y {-False-}
698 ISrlOp -> shift_code (SHR L) x y {-False-}
700 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
701 [promote x, promote y])
702 where promote x = StPrim Float2DoubleOp [x]
703 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
706 -> pprPanic "getRegister(x86,dyadic primop)"
707 (pprStixTree (StPrim primop [x, y]))
711 shift_code :: (Imm -> Operand -> Instr)
716 {- Case1: shift length as immediate -}
717 -- Code is the same as the first eq. for trivialCode -- sigh.
718 shift_code instr x y{-amount-}
720 = getRegister x `thenNat` \ regx ->
723 then registerCodeA regx dst `bind` \ code_x ->
725 instr imm__2 (OpReg dst)
726 else registerCodeF regx `bind` \ code_x ->
727 registerNameF regx `bind` \ r_x ->
729 MOV L (OpReg r_x) (OpReg dst) `snocOL`
730 instr imm__2 (OpReg dst)
732 returnNat (Any IntRep mkcode)
735 imm__2 = case imm of Just x -> x
737 {- Case2: shift length is complex (non-immediate) -}
738 -- Since ECX is always used as a spill temporary, we can't
739 -- use it here to do non-immediate shifts. No big deal --
740 -- they are only very rare, and we can use an equivalent
741 -- test-and-jump sequence which doesn't use ECX.
742 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
743 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
744 shift_code instr x y{-amount-}
745 = getRegister x `thenNat` \ register1 ->
746 getRegister y `thenNat` \ register2 ->
747 getNatLabelNCG `thenNat` \ lbl_test3 ->
748 getNatLabelNCG `thenNat` \ lbl_test2 ->
749 getNatLabelNCG `thenNat` \ lbl_test1 ->
750 getNatLabelNCG `thenNat` \ lbl_test0 ->
751 getNatLabelNCG `thenNat` \ lbl_after ->
752 getNewRegNCG IntRep `thenNat` \ tmp ->
754 = let src_val = registerName register1 dst
755 code_val = registerCode register1 dst
756 src_amt = registerName register2 tmp
757 code_amt = registerCode register2 tmp
762 MOV L (OpReg src_amt) r_tmp `appOL`
764 MOV L (OpReg src_val) r_dst `appOL`
766 COMMENT (_PK_ "begin shift sequence"),
767 MOV L (OpReg src_val) r_dst,
768 MOV L (OpReg src_amt) r_tmp,
770 BT L (ImmInt 4) r_tmp,
772 instr (ImmInt 16) r_dst,
775 BT L (ImmInt 3) r_tmp,
777 instr (ImmInt 8) r_dst,
780 BT L (ImmInt 2) r_tmp,
782 instr (ImmInt 4) r_dst,
785 BT L (ImmInt 1) r_tmp,
787 instr (ImmInt 2) r_dst,
790 BT L (ImmInt 0) r_tmp,
792 instr (ImmInt 1) r_dst,
795 COMMENT (_PK_ "end shift sequence")
798 returnNat (Any IntRep code__2)
801 add_code :: Size -> StixTree -> StixTree -> NatM Register
803 add_code sz x (StInt y)
804 = getRegister x `thenNat` \ register ->
805 getNewRegNCG IntRep `thenNat` \ tmp ->
807 code = registerCode register tmp
808 src1 = registerName register tmp
809 src2 = ImmInt (fromInteger y)
812 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
815 returnNat (Any IntRep code__2)
817 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
820 sub_code :: Size -> StixTree -> StixTree -> NatM Register
822 sub_code sz x (StInt y)
823 = getRegister x `thenNat` \ register ->
824 getNewRegNCG IntRep `thenNat` \ tmp ->
826 code = registerCode register tmp
827 src1 = registerName register tmp
828 src2 = ImmInt (-(fromInteger y))
831 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
834 returnNat (Any IntRep code__2)
836 sub_code sz x y = trivialCode (SUB sz) Nothing x y
839 getRegister (StInd pk mem)
840 = getAmode mem `thenNat` \ amode ->
842 code = amodeCode amode
843 src = amodeAddr amode
844 size = primRepToSize pk
845 code__2 dst = code `snocOL`
846 if pk == DoubleRep || pk == FloatRep
847 then GLD size src dst
849 L -> MOV L (OpAddr src) (OpReg dst)
850 BU -> MOVZxL BU (OpAddr src) (OpReg dst)
852 returnNat (Any pk code__2)
854 getRegister (StInt i)
856 src = ImmInt (fromInteger i)
859 = unitOL (XOR L (OpReg dst) (OpReg dst))
861 = unitOL (MOV L (OpImm src) (OpReg dst))
863 returnNat (Any IntRep code)
867 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
869 returnNat (Any PtrRep code)
871 = pprPanic "getRegister(x86)" (pprStixTree leaf)
874 imm__2 = case imm of Just x -> x
876 #endif {- i386_TARGET_ARCH -}
877 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
878 #if sparc_TARGET_ARCH
880 getRegister (StFloat d)
881 = getNatLabelNCG `thenNat` \ lbl ->
882 getNewRegNCG PtrRep `thenNat` \ tmp ->
883 let code dst = toOL [
888 SETHI (HI (ImmCLbl lbl)) tmp,
889 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
891 returnNat (Any FloatRep code)
893 getRegister (StDouble d)
894 = getNatLabelNCG `thenNat` \ lbl ->
895 getNewRegNCG PtrRep `thenNat` \ tmp ->
896 let code dst = toOL [
899 DATA DF [ImmDouble d],
901 SETHI (HI (ImmCLbl lbl)) tmp,
902 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
904 returnNat (Any DoubleRep code)
906 -- The 6-word scratch area is immediately below the frame pointer.
907 -- Below that is the spill area.
908 getRegister (StScratchWord i)
911 code dst = unitOL (fpRelEA j dst)
913 returnNat (Any PtrRep code)
916 getRegister (StPrim primop [x]) -- unary PrimOps
918 IntNegOp -> trivialUCode (SUB False False g0) x
919 NotOp -> trivialUCode (XNOR False g0) x
921 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
922 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
924 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
925 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
927 OrdOp -> coerceIntCode IntRep x
930 Float2IntOp -> coerceFP2Int x
931 Int2FloatOp -> coerceInt2FP FloatRep x
932 Double2IntOp -> coerceFP2Int x
933 Int2DoubleOp -> coerceInt2FP DoubleRep x
937 fixed_x = if is_float_op -- promote to double
938 then StPrim Float2DoubleOp [x]
941 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
945 FloatExpOp -> (True, SLIT("exp"))
946 FloatLogOp -> (True, SLIT("log"))
947 FloatSqrtOp -> (True, SLIT("sqrt"))
949 FloatSinOp -> (True, SLIT("sin"))
950 FloatCosOp -> (True, SLIT("cos"))
951 FloatTanOp -> (True, SLIT("tan"))
953 FloatAsinOp -> (True, SLIT("asin"))
954 FloatAcosOp -> (True, SLIT("acos"))
955 FloatAtanOp -> (True, SLIT("atan"))
957 FloatSinhOp -> (True, SLIT("sinh"))
958 FloatCoshOp -> (True, SLIT("cosh"))
959 FloatTanhOp -> (True, SLIT("tanh"))
961 DoubleExpOp -> (False, SLIT("exp"))
962 DoubleLogOp -> (False, SLIT("log"))
963 DoubleSqrtOp -> (False, SLIT("sqrt"))
965 DoubleSinOp -> (False, SLIT("sin"))
966 DoubleCosOp -> (False, SLIT("cos"))
967 DoubleTanOp -> (False, SLIT("tan"))
969 DoubleAsinOp -> (False, SLIT("asin"))
970 DoubleAcosOp -> (False, SLIT("acos"))
971 DoubleAtanOp -> (False, SLIT("atan"))
973 DoubleSinhOp -> (False, SLIT("sinh"))
974 DoubleCoshOp -> (False, SLIT("cosh"))
975 DoubleTanhOp -> (False, SLIT("tanh"))
978 -> pprPanic "getRegister(sparc,monadicprimop)"
979 (pprStixTree (StPrim primop [x]))
981 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
983 CharGtOp -> condIntReg GTT x y
984 CharGeOp -> condIntReg GE x y
985 CharEqOp -> condIntReg EQQ x y
986 CharNeOp -> condIntReg NE x y
987 CharLtOp -> condIntReg LTT x y
988 CharLeOp -> condIntReg LE x y
990 IntGtOp -> condIntReg GTT x y
991 IntGeOp -> condIntReg GE x y
992 IntEqOp -> condIntReg EQQ x y
993 IntNeOp -> condIntReg NE x y
994 IntLtOp -> condIntReg LTT x y
995 IntLeOp -> condIntReg LE x y
997 WordGtOp -> condIntReg GU x y
998 WordGeOp -> condIntReg GEU x y
999 WordEqOp -> condIntReg EQQ x y
1000 WordNeOp -> condIntReg NE x y
1001 WordLtOp -> condIntReg LU x y
1002 WordLeOp -> condIntReg LEU x y
1004 AddrGtOp -> condIntReg GU x y
1005 AddrGeOp -> condIntReg GEU x y
1006 AddrEqOp -> condIntReg EQQ x y
1007 AddrNeOp -> condIntReg NE x y
1008 AddrLtOp -> condIntReg LU x y
1009 AddrLeOp -> condIntReg LEU x y
1011 FloatGtOp -> condFltReg GTT x y
1012 FloatGeOp -> condFltReg GE x y
1013 FloatEqOp -> condFltReg EQQ x y
1014 FloatNeOp -> condFltReg NE x y
1015 FloatLtOp -> condFltReg LTT x y
1016 FloatLeOp -> condFltReg LE x y
1018 DoubleGtOp -> condFltReg GTT x y
1019 DoubleGeOp -> condFltReg GE x y
1020 DoubleEqOp -> condFltReg EQQ x y
1021 DoubleNeOp -> condFltReg NE x y
1022 DoubleLtOp -> condFltReg LTT x y
1023 DoubleLeOp -> condFltReg LE x y
1025 IntAddOp -> trivialCode (ADD False False) x y
1026 IntSubOp -> trivialCode (SUB False False) x y
1028 -- ToDo: teach about V8+ SPARC mul/div instructions
1029 IntMulOp -> imul_div SLIT(".umul") x y
1030 IntQuotOp -> imul_div SLIT(".div") x y
1031 IntRemOp -> imul_div SLIT(".rem") x y
1033 FloatAddOp -> trivialFCode FloatRep FADD x y
1034 FloatSubOp -> trivialFCode FloatRep FSUB x y
1035 FloatMulOp -> trivialFCode FloatRep FMUL x y
1036 FloatDivOp -> trivialFCode FloatRep FDIV x y
1038 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1039 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1040 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1041 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1043 AndOp -> trivialCode (AND False) x y
1044 OrOp -> trivialCode (OR False) x y
1045 XorOp -> trivialCode (XOR False) x y
1046 SllOp -> trivialCode SLL x y
1047 SrlOp -> trivialCode SRL x y
1049 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1050 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1051 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1053 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1054 [promote x, promote y])
1055 where promote x = StPrim Float2DoubleOp [x]
1056 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1060 -> pprPanic "getRegister(sparc,dyadic primop)"
1061 (pprStixTree (StPrim primop [x, y]))
1064 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1066 getRegister (StInd pk mem)
1067 = getAmode mem `thenNat` \ amode ->
1069 code = amodeCode amode
1070 src = amodeAddr amode
1071 size = primRepToSize pk
1072 code__2 dst = code `snocOL` LD size src dst
1074 returnNat (Any pk code__2)
1076 getRegister (StInt i)
1079 src = ImmInt (fromInteger i)
1080 code dst = unitOL (OR False g0 (RIImm src) dst)
1082 returnNat (Any IntRep code)
1088 SETHI (HI imm__2) dst,
1089 OR False dst (RIImm (LO imm__2)) dst]
1091 returnNat (Any PtrRep code)
1093 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1096 imm__2 = case imm of Just x -> x
1098 #endif {- sparc_TARGET_ARCH -}
1101 %************************************************************************
1103 \subsection{The @Amode@ type}
1105 %************************************************************************
1107 @Amode@s: Memory addressing modes passed up the tree.
1109 data Amode = Amode MachRegsAddr InstrBlock
1111 amodeAddr (Amode addr _) = addr
1112 amodeCode (Amode _ code) = code
1115 Now, given a tree (the argument to an StInd) that references memory,
1116 produce a suitable addressing mode.
1118 A Rule of the Game (tm) for Amodes: use of the addr bit must
1119 immediately follow use of the code part, since the code part puts
1120 values in registers which the addr then refers to. So you can't put
1121 anything in between, lest it overwrite some of those registers. If
1122 you need to do some other computation between the code part and use of
1123 the addr bit, first store the effective address from the amode in a
1124 temporary, then do the other computation, and then use the temporary:
1128 ... other computation ...
1132 getAmode :: StixTree -> NatM Amode
1134 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1136 #if alpha_TARGET_ARCH
1138 getAmode (StPrim IntSubOp [x, StInt i])
1139 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1140 getRegister x `thenNat` \ register ->
1142 code = registerCode register tmp
1143 reg = registerName register tmp
1144 off = ImmInt (-(fromInteger i))
1146 returnNat (Amode (AddrRegImm reg off) code)
1148 getAmode (StPrim IntAddOp [x, StInt i])
1149 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1150 getRegister x `thenNat` \ register ->
1152 code = registerCode register tmp
1153 reg = registerName register tmp
1154 off = ImmInt (fromInteger i)
1156 returnNat (Amode (AddrRegImm reg off) code)
1160 = returnNat (Amode (AddrImm imm__2) id)
1163 imm__2 = case imm of Just x -> x
1166 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1167 getRegister other `thenNat` \ register ->
1169 code = registerCode register tmp
1170 reg = registerName register tmp
1172 returnNat (Amode (AddrReg reg) code)
1174 #endif {- alpha_TARGET_ARCH -}
1175 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1176 #if i386_TARGET_ARCH
1178 getAmode (StPrim IntSubOp [x, StInt i])
1179 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1180 getRegister x `thenNat` \ register ->
1182 code = registerCode register tmp
1183 reg = registerName register tmp
1184 off = ImmInt (-(fromInteger i))
1186 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1188 getAmode (StPrim IntAddOp [x, StInt i])
1190 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1193 imm__2 = case imm of Just x -> x
1195 getAmode (StPrim IntAddOp [x, StInt i])
1196 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1197 getRegister x `thenNat` \ register ->
1199 code = registerCode register tmp
1200 reg = registerName register tmp
1201 off = ImmInt (fromInteger i)
1203 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1205 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1206 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1207 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1208 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1209 getRegister x `thenNat` \ register1 ->
1210 getRegister y `thenNat` \ register2 ->
1212 code1 = registerCode register1 tmp1
1213 reg1 = registerName register1 tmp1
1214 code2 = registerCode register2 tmp2
1215 reg2 = registerName register2 tmp2
1216 code__2 = code1 `appOL` code2
1217 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1219 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1224 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1227 imm__2 = case imm of Just x -> x
1230 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1231 getRegister other `thenNat` \ register ->
1233 code = registerCode register tmp
1234 reg = registerName register tmp
1236 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1238 #endif {- i386_TARGET_ARCH -}
1239 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1240 #if sparc_TARGET_ARCH
1242 getAmode (StPrim IntSubOp [x, StInt i])
1244 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1245 getRegister x `thenNat` \ register ->
1247 code = registerCode register tmp
1248 reg = registerName register tmp
1249 off = ImmInt (-(fromInteger i))
1251 returnNat (Amode (AddrRegImm reg off) code)
1254 getAmode (StPrim IntAddOp [x, StInt i])
1256 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1257 getRegister x `thenNat` \ register ->
1259 code = registerCode register tmp
1260 reg = registerName register tmp
1261 off = ImmInt (fromInteger i)
1263 returnNat (Amode (AddrRegImm reg off) code)
1265 getAmode (StPrim IntAddOp [x, y])
1266 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1267 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1268 getRegister x `thenNat` \ register1 ->
1269 getRegister y `thenNat` \ register2 ->
1271 code1 = registerCode register1 tmp1
1272 reg1 = registerName register1 tmp1
1273 code2 = registerCode register2 tmp2
1274 reg2 = registerName register2 tmp2
1275 code__2 = code1 `appOL` code2
1277 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1281 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1283 code = unitOL (SETHI (HI imm__2) tmp)
1285 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1288 imm__2 = case imm of Just x -> x
1291 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1292 getRegister other `thenNat` \ register ->
1294 code = registerCode register tmp
1295 reg = registerName register tmp
1298 returnNat (Amode (AddrRegImm reg off) code)
1300 #endif {- sparc_TARGET_ARCH -}
1303 %************************************************************************
1305 \subsection{The @CondCode@ type}
1307 %************************************************************************
1309 Condition codes passed up the tree.
1311 data CondCode = CondCode Bool Cond InstrBlock
1313 condName (CondCode _ cond _) = cond
1314 condFloat (CondCode is_float _ _) = is_float
1315 condCode (CondCode _ _ code) = code
1318 Set up a condition code for a conditional branch.
1321 getCondCode :: StixTree -> NatM CondCode
1323 #if alpha_TARGET_ARCH
1324 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1325 #endif {- alpha_TARGET_ARCH -}
1326 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1328 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1329 -- yes, they really do seem to want exactly the same!
1331 getCondCode (StPrim primop [x, y])
1333 CharGtOp -> condIntCode GTT x y
1334 CharGeOp -> condIntCode GE x y
1335 CharEqOp -> condIntCode EQQ x y
1336 CharNeOp -> condIntCode NE x y
1337 CharLtOp -> condIntCode LTT x y
1338 CharLeOp -> condIntCode LE x y
1340 IntGtOp -> condIntCode GTT x y
1341 IntGeOp -> condIntCode GE x y
1342 IntEqOp -> condIntCode EQQ x y
1343 IntNeOp -> condIntCode NE x y
1344 IntLtOp -> condIntCode LTT x y
1345 IntLeOp -> condIntCode LE x y
1347 WordGtOp -> condIntCode GU x y
1348 WordGeOp -> condIntCode GEU x y
1349 WordEqOp -> condIntCode EQQ x y
1350 WordNeOp -> condIntCode NE x y
1351 WordLtOp -> condIntCode LU x y
1352 WordLeOp -> condIntCode LEU x y
1354 AddrGtOp -> condIntCode GU x y
1355 AddrGeOp -> condIntCode GEU x y
1356 AddrEqOp -> condIntCode EQQ x y
1357 AddrNeOp -> condIntCode NE x y
1358 AddrLtOp -> condIntCode LU x y
1359 AddrLeOp -> condIntCode LEU x y
1361 FloatGtOp -> condFltCode GTT x y
1362 FloatGeOp -> condFltCode GE x y
1363 FloatEqOp -> condFltCode EQQ x y
1364 FloatNeOp -> condFltCode NE x y
1365 FloatLtOp -> condFltCode LTT x y
1366 FloatLeOp -> condFltCode LE x y
1368 DoubleGtOp -> condFltCode GTT x y
1369 DoubleGeOp -> condFltCode GE x y
1370 DoubleEqOp -> condFltCode EQQ x y
1371 DoubleNeOp -> condFltCode NE x y
1372 DoubleLtOp -> condFltCode LTT x y
1373 DoubleLeOp -> condFltCode LE x y
1375 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1380 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1381 passed back up the tree.
1384 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1386 #if alpha_TARGET_ARCH
1387 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1388 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1389 #endif {- alpha_TARGET_ARCH -}
1391 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1392 #if i386_TARGET_ARCH
1394 -- memory vs immediate
1395 condIntCode cond (StInd pk x) y
1397 = getAmode x `thenNat` \ amode ->
1399 code1 = amodeCode amode
1400 x__2 = amodeAddr amode
1401 sz = primRepToSize pk
1402 code__2 = code1 `snocOL`
1403 CMP sz (OpImm imm__2) (OpAddr x__2)
1405 returnNat (CondCode False cond code__2)
1408 imm__2 = case imm of Just x -> x
1411 condIntCode cond x (StInt 0)
1412 = getRegister x `thenNat` \ register1 ->
1413 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1415 code1 = registerCode register1 tmp1
1416 src1 = registerName register1 tmp1
1417 code__2 = code1 `snocOL`
1418 TEST L (OpReg src1) (OpReg src1)
1420 returnNat (CondCode False cond code__2)
1422 -- anything vs immediate
1423 condIntCode cond x y
1425 = getRegister x `thenNat` \ register1 ->
1426 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1428 code1 = registerCode register1 tmp1
1429 src1 = registerName register1 tmp1
1430 code__2 = code1 `snocOL`
1431 CMP L (OpImm imm__2) (OpReg src1)
1433 returnNat (CondCode False cond code__2)
1436 imm__2 = case imm of Just x -> x
1438 -- memory vs anything
1439 condIntCode cond (StInd pk x) y
1440 = getAmode x `thenNat` \ amode_x ->
1441 getRegister y `thenNat` \ reg_y ->
1442 getNewRegNCG IntRep `thenNat` \ tmp ->
1444 c_x = amodeCode amode_x
1445 am_x = amodeAddr amode_x
1446 c_y = registerCode reg_y tmp
1447 r_y = registerName reg_y tmp
1448 sz = primRepToSize pk
1450 -- optimisation: if there's no code for x, just an amode,
1451 -- use whatever reg y winds up in. Assumes that c_y doesn't
1452 -- clobber any regs in the amode am_x, which I'm not sure is
1453 -- justified. The otherwise clause makes the same assumption.
1454 code__2 | isNilOL c_x
1456 CMP sz (OpReg r_y) (OpAddr am_x)
1460 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1462 CMP sz (OpReg tmp) (OpAddr am_x)
1464 returnNat (CondCode False cond code__2)
1466 -- anything vs memory
1468 condIntCode cond y (StInd pk x)
1469 = getAmode x `thenNat` \ amode_x ->
1470 getRegister y `thenNat` \ reg_y ->
1471 getNewRegNCG IntRep `thenNat` \ tmp ->
1473 c_x = amodeCode amode_x
1474 am_x = amodeAddr amode_x
1475 c_y = registerCode reg_y tmp
1476 r_y = registerName reg_y tmp
1477 sz = primRepToSize pk
1478 -- same optimisation and nagging doubts as previous clause
1479 code__2 | isNilOL c_x
1481 CMP sz (OpAddr am_x) (OpReg r_y)
1485 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1487 CMP sz (OpAddr am_x) (OpReg tmp)
1489 returnNat (CondCode False cond code__2)
1491 -- anything vs anything
1492 condIntCode cond x y
1493 = getRegister x `thenNat` \ register1 ->
1494 getRegister y `thenNat` \ register2 ->
1495 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1496 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1498 code1 = registerCode register1 tmp1
1499 src1 = registerName register1 tmp1
1500 code2 = registerCode register2 tmp2
1501 src2 = registerName register2 tmp2
1502 code__2 = code1 `snocOL`
1503 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1505 CMP L (OpReg src2) (OpReg tmp1)
1507 returnNat (CondCode False cond code__2)
1510 condFltCode cond x y
1511 = getRegister x `thenNat` \ register1 ->
1512 getRegister y `thenNat` \ register2 ->
1513 getNewRegNCG (registerRep register1)
1515 getNewRegNCG (registerRep register2)
1517 getNewRegNCG DoubleRep `thenNat` \ tmp ->
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 | isAny register1
1527 = code1 `appOL` -- result in tmp1
1529 GCMP (primRepToSize pk1) tmp1 src2
1533 GMOV src1 tmp1 `appOL`
1535 GCMP (primRepToSize pk1) tmp1 src2
1537 {- On the 486, the flags set by FP compare are the unsigned ones!
1538 (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 returnNat (CondCode True (fix_FP_cond cond) code__2)
1552 #endif {- i386_TARGET_ARCH -}
1553 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1554 #if sparc_TARGET_ARCH
1556 condIntCode cond x (StInt y)
1558 = getRegister x `thenNat` \ register ->
1559 getNewRegNCG IntRep `thenNat` \ tmp ->
1561 code = registerCode register tmp
1562 src1 = registerName register tmp
1563 src2 = ImmInt (fromInteger y)
1564 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1566 returnNat (CondCode False cond code__2)
1568 condIntCode cond x y
1569 = getRegister x `thenNat` \ register1 ->
1570 getRegister y `thenNat` \ register2 ->
1571 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1572 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1574 code1 = registerCode register1 tmp1
1575 src1 = registerName register1 tmp1
1576 code2 = registerCode register2 tmp2
1577 src2 = registerName register2 tmp2
1578 code__2 = code1 `appOL` code2 `snocOL`
1579 SUB False True src1 (RIReg src2) g0
1581 returnNat (CondCode False cond code__2)
1584 condFltCode cond x y
1585 = getRegister x `thenNat` \ register1 ->
1586 getRegister y `thenNat` \ register2 ->
1587 getNewRegNCG (registerRep register1)
1589 getNewRegNCG (registerRep register2)
1591 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1593 promote x = FxTOy F DF x tmp
1595 pk1 = registerRep register1
1596 code1 = registerCode register1 tmp1
1597 src1 = registerName register1 tmp1
1599 pk2 = registerRep register2
1600 code2 = registerCode register2 tmp2
1601 src2 = registerName register2 tmp2
1605 code1 `appOL` code2 `snocOL`
1606 FCMP True (primRepToSize pk1) src1 src2
1607 else if pk1 == FloatRep then
1608 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1609 FCMP True DF tmp src2
1611 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1612 FCMP True DF src1 tmp
1614 returnNat (CondCode True cond code__2)
1616 #endif {- sparc_TARGET_ARCH -}
1619 %************************************************************************
1621 \subsection{Generating assignments}
1623 %************************************************************************
1625 Assignments are really at the heart of the whole code generation
1626 business. Almost all top-level nodes of any real importance are
1627 assignments, which correspond to loads, stores, or register transfers.
1628 If we're really lucky, some of the register transfers will go away,
1629 because we can use the destination register to complete the code
1630 generation for the right hand side. This only fails when the right
1631 hand side is forced into a fixed register (e.g. the result of a call).
1634 assignIntCode, assignFltCode
1635 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1637 #if alpha_TARGET_ARCH
1639 assignIntCode pk (StInd _ dst) src
1640 = getNewRegNCG IntRep `thenNat` \ tmp ->
1641 getAmode dst `thenNat` \ amode ->
1642 getRegister src `thenNat` \ register ->
1644 code1 = amodeCode amode []
1645 dst__2 = amodeAddr amode
1646 code2 = registerCode register tmp []
1647 src__2 = registerName register tmp
1648 sz = primRepToSize pk
1649 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1653 assignIntCode pk dst src
1654 = getRegister dst `thenNat` \ register1 ->
1655 getRegister src `thenNat` \ register2 ->
1657 dst__2 = registerName register1 zeroh
1658 code = registerCode register2 dst__2
1659 src__2 = registerName register2 dst__2
1660 code__2 = if isFixed register2
1661 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1666 #endif {- alpha_TARGET_ARCH -}
1667 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1668 #if i386_TARGET_ARCH
1670 -- Destination of an assignment can only be reg or mem.
1671 -- This is the mem case.
1672 assignIntCode pk (StInd _ dst) src
1673 = getAmode dst `thenNat` \ amode ->
1674 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1675 getNewRegNCG PtrRep `thenNat` \ tmp ->
1677 -- In general, if the address computation for dst may require
1678 -- some insns preceding the addressing mode itself. So there's
1679 -- no guarantee that the code for dst and the code for src won't
1680 -- write the same register. This means either the address or
1681 -- the value needs to be copied into a temporary. We detect the
1682 -- common case where the amode has no code, and elide the copy.
1683 codea = amodeCode amode
1684 dst__a = amodeAddr amode
1686 code | isNilOL codea
1688 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1692 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1694 MOV (primRepToSize pk) opsrc
1695 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1701 -> NatM (InstrBlock,Operand) -- code, operator
1705 = returnNat (nilOL, OpImm imm_op)
1708 imm_op = case imm of Just x -> x
1711 = getRegister op `thenNat` \ register ->
1712 getNewRegNCG (registerRep register)
1714 let code = registerCode register tmp
1715 reg = registerName register tmp
1717 returnNat (code, OpReg reg)
1719 -- Assign; dst is a reg, rhs is mem
1720 assignIntCode pk dst (StInd pks src)
1721 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1722 getAmode src `thenNat` \ amode ->
1723 getRegister dst `thenNat` \ reg_dst ->
1725 c_addr = amodeCode amode
1726 am_addr = amodeAddr amode
1728 c_dst = registerCode reg_dst tmp -- should be empty
1729 r_dst = registerName reg_dst tmp
1730 szs = primRepToSize pks
1731 opc = case szs of L -> MOV L ; BU -> MOVZxL BU
1733 code | isNilOL c_dst
1735 opc (OpAddr am_addr) (OpReg r_dst)
1737 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1741 -- dst is a reg, but src could be anything
1742 assignIntCode pk dst src
1743 = getRegister dst `thenNat` \ registerd ->
1744 getRegister src `thenNat` \ registers ->
1745 getNewRegNCG IntRep `thenNat` \ tmp ->
1747 r_dst = registerName registerd tmp
1748 c_dst = registerCode registerd tmp -- should be empty
1749 r_src = registerName registers r_dst
1750 c_src = registerCode registers r_dst
1752 code | isNilOL c_dst
1754 MOV L (OpReg r_src) (OpReg r_dst)
1756 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1760 #endif {- i386_TARGET_ARCH -}
1761 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1762 #if sparc_TARGET_ARCH
1764 assignIntCode pk (StInd _ dst) src
1765 = getNewRegNCG IntRep `thenNat` \ tmp ->
1766 getAmode dst `thenNat` \ amode ->
1767 getRegister src `thenNat` \ register ->
1769 code1 = amodeCode amode
1770 dst__2 = amodeAddr amode
1771 code2 = registerCode register tmp
1772 src__2 = registerName register tmp
1773 sz = primRepToSize pk
1774 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1778 assignIntCode pk dst src
1779 = getRegister dst `thenNat` \ register1 ->
1780 getRegister src `thenNat` \ register2 ->
1782 dst__2 = registerName register1 g0
1783 code = registerCode register2 dst__2
1784 src__2 = registerName register2 dst__2
1785 code__2 = if isFixed register2
1786 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1791 #endif {- sparc_TARGET_ARCH -}
1794 % --------------------------------
1795 Floating-point assignments:
1796 % --------------------------------
1798 #if alpha_TARGET_ARCH
1800 assignFltCode pk (StInd _ dst) src
1801 = getNewRegNCG pk `thenNat` \ tmp ->
1802 getAmode dst `thenNat` \ amode ->
1803 getRegister src `thenNat` \ register ->
1805 code1 = amodeCode amode []
1806 dst__2 = amodeAddr amode
1807 code2 = registerCode register tmp []
1808 src__2 = registerName register tmp
1809 sz = primRepToSize pk
1810 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1814 assignFltCode pk dst src
1815 = getRegister dst `thenNat` \ register1 ->
1816 getRegister src `thenNat` \ register2 ->
1818 dst__2 = registerName register1 zeroh
1819 code = registerCode register2 dst__2
1820 src__2 = registerName register2 dst__2
1821 code__2 = if isFixed register2
1822 then code . mkSeqInstr (FMOV src__2 dst__2)
1827 #endif {- alpha_TARGET_ARCH -}
1828 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1829 #if i386_TARGET_ARCH
1832 assignFltCode pk (StInd pk_dst addr) src
1834 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1836 = getRegister src `thenNat` \ reg_src ->
1837 getRegister addr `thenNat` \ reg_addr ->
1838 getNewRegNCG pk `thenNat` \ tmp_src ->
1839 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1840 let r_src = registerName reg_src tmp_src
1841 c_src = registerCode reg_src tmp_src
1842 r_addr = registerName reg_addr tmp_addr
1843 c_addr = registerCode reg_addr tmp_addr
1844 sz = primRepToSize pk
1846 code = c_src `appOL`
1847 -- no need to preserve r_src across the addr computation,
1848 -- since r_src must be a float reg
1849 -- whilst r_addr is an int reg
1852 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1856 -- dst must be a (FP) register
1857 assignFltCode pk dst src
1858 = getRegister dst `thenNat` \ reg_dst ->
1859 getRegister src `thenNat` \ reg_src ->
1860 getNewRegNCG pk `thenNat` \ tmp ->
1862 r_dst = registerName reg_dst tmp
1863 c_dst = registerCode reg_dst tmp -- should be empty
1865 r_src = registerName reg_src r_dst
1866 c_src = registerCode reg_src r_dst
1868 code | isNilOL c_dst
1869 = if isFixed reg_src
1870 then c_src `snocOL` GMOV r_src r_dst
1873 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1879 #endif {- i386_TARGET_ARCH -}
1880 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1881 #if sparc_TARGET_ARCH
1883 assignFltCode pk (StInd _ dst) src
1884 = getNewRegNCG pk `thenNat` \ tmp1 ->
1885 getAmode dst `thenNat` \ amode ->
1886 getRegister src `thenNat` \ register ->
1888 sz = primRepToSize pk
1889 dst__2 = amodeAddr amode
1891 code1 = amodeCode amode
1892 code2 = registerCode register tmp1
1894 src__2 = registerName register tmp1
1895 pk__2 = registerRep register
1896 sz__2 = primRepToSize pk__2
1898 code__2 = code1 `appOL` code2 `appOL`
1900 then unitOL (ST sz src__2 dst__2)
1901 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1905 assignFltCode pk dst src
1906 = getRegister dst `thenNat` \ register1 ->
1907 getRegister src `thenNat` \ register2 ->
1909 pk__2 = registerRep register2
1910 sz__2 = primRepToSize pk__2
1912 getNewRegNCG pk__2 `thenNat` \ tmp ->
1914 sz = primRepToSize pk
1915 dst__2 = registerName register1 g0 -- must be Fixed
1918 reg__2 = if pk /= pk__2 then tmp else dst__2
1920 code = registerCode register2 reg__2
1922 src__2 = registerName register2 reg__2
1926 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1927 else if isFixed register2 then
1928 code `snocOL` FMOV sz src__2 dst__2
1934 #endif {- sparc_TARGET_ARCH -}
1937 %************************************************************************
1939 \subsection{Generating an unconditional branch}
1941 %************************************************************************
1943 We accept two types of targets: an immediate CLabel or a tree that
1944 gets evaluated into a register. Any CLabels which are AsmTemporaries
1945 are assumed to be in the local block of code, close enough for a
1946 branch instruction. Other CLabels are assumed to be far away.
1948 (If applicable) Do not fill the delay slots here; you will confuse the
1952 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
1954 #if alpha_TARGET_ARCH
1956 genJump (StCLbl lbl)
1957 | isAsmTemp lbl = returnInstr (BR target)
1958 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1960 target = ImmCLbl lbl
1963 = getRegister tree `thenNat` \ register ->
1964 getNewRegNCG PtrRep `thenNat` \ tmp ->
1966 dst = registerName register pv
1967 code = registerCode register pv
1968 target = registerName register pv
1970 if isFixed register then
1971 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1973 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1975 #endif {- alpha_TARGET_ARCH -}
1976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1977 #if i386_TARGET_ARCH
1979 genJump dsts (StInd pk mem)
1980 = getAmode mem `thenNat` \ amode ->
1982 code = amodeCode amode
1983 target = amodeAddr amode
1985 returnNat (code `snocOL` JMP dsts (OpAddr target))
1989 = returnNat (unitOL (JMP dsts (OpImm target)))
1992 = getRegister tree `thenNat` \ register ->
1993 getNewRegNCG PtrRep `thenNat` \ tmp ->
1995 code = registerCode register tmp
1996 target = registerName register tmp
1998 returnNat (code `snocOL` JMP dsts (OpReg target))
2001 target = case imm of Just x -> x
2003 #endif {- i386_TARGET_ARCH -}
2004 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2005 #if sparc_TARGET_ARCH
2007 genJump dsts (StCLbl lbl)
2008 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2009 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2010 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2012 target = ImmCLbl lbl
2015 = getRegister tree `thenNat` \ register ->
2016 getNewRegNCG PtrRep `thenNat` \ tmp ->
2018 code = registerCode register tmp
2019 target = registerName register tmp
2021 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2023 #endif {- sparc_TARGET_ARCH -}
2026 %************************************************************************
2028 \subsection{Conditional jumps}
2030 %************************************************************************
2032 Conditional jumps are always to local labels, so we can use branch
2033 instructions. We peek at the arguments to decide what kind of
2036 ALPHA: For comparisons with 0, we're laughing, because we can just do
2037 the desired conditional branch.
2039 I386: First, we have to ensure that the condition
2040 codes are set according to the supplied comparison operation.
2042 SPARC: First, we have to ensure that the condition codes are set
2043 according to the supplied comparison operation. We generate slightly
2044 different code for floating point comparisons, because a floating
2045 point operation cannot directly precede a @BF@. We assume the worst
2046 and fill that slot with a @NOP@.
2048 SPARC: Do not fill the delay slots here; you will confuse the register
2053 :: CLabel -- the branch target
2054 -> StixTree -- the condition on which to branch
2057 #if alpha_TARGET_ARCH
2059 genCondJump lbl (StPrim op [x, StInt 0])
2060 = getRegister x `thenNat` \ register ->
2061 getNewRegNCG (registerRep register)
2064 code = registerCode register tmp
2065 value = registerName register tmp
2066 pk = registerRep register
2067 target = ImmCLbl lbl
2069 returnSeq code [BI (cmpOp op) value target]
2071 cmpOp CharGtOp = GTT
2073 cmpOp CharEqOp = EQQ
2075 cmpOp CharLtOp = LTT
2084 cmpOp WordGeOp = ALWAYS
2085 cmpOp WordEqOp = EQQ
2087 cmpOp WordLtOp = NEVER
2088 cmpOp WordLeOp = EQQ
2090 cmpOp AddrGeOp = ALWAYS
2091 cmpOp AddrEqOp = EQQ
2093 cmpOp AddrLtOp = NEVER
2094 cmpOp AddrLeOp = EQQ
2096 genCondJump lbl (StPrim op [x, StDouble 0.0])
2097 = getRegister x `thenNat` \ register ->
2098 getNewRegNCG (registerRep register)
2101 code = registerCode register tmp
2102 value = registerName register tmp
2103 pk = registerRep register
2104 target = ImmCLbl lbl
2106 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2108 cmpOp FloatGtOp = GTT
2109 cmpOp FloatGeOp = GE
2110 cmpOp FloatEqOp = EQQ
2111 cmpOp FloatNeOp = NE
2112 cmpOp FloatLtOp = LTT
2113 cmpOp FloatLeOp = LE
2114 cmpOp DoubleGtOp = GTT
2115 cmpOp DoubleGeOp = GE
2116 cmpOp DoubleEqOp = EQQ
2117 cmpOp DoubleNeOp = NE
2118 cmpOp DoubleLtOp = LTT
2119 cmpOp DoubleLeOp = LE
2121 genCondJump lbl (StPrim op [x, y])
2123 = trivialFCode pr instr x y `thenNat` \ register ->
2124 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2126 code = registerCode register tmp
2127 result = registerName register tmp
2128 target = ImmCLbl lbl
2130 returnNat (code . mkSeqInstr (BF cond result target))
2132 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2134 fltCmpOp op = case op of
2148 (instr, cond) = case op of
2149 FloatGtOp -> (FCMP TF LE, EQQ)
2150 FloatGeOp -> (FCMP TF LTT, EQQ)
2151 FloatEqOp -> (FCMP TF EQQ, NE)
2152 FloatNeOp -> (FCMP TF EQQ, EQQ)
2153 FloatLtOp -> (FCMP TF LTT, NE)
2154 FloatLeOp -> (FCMP TF LE, NE)
2155 DoubleGtOp -> (FCMP TF LE, EQQ)
2156 DoubleGeOp -> (FCMP TF LTT, EQQ)
2157 DoubleEqOp -> (FCMP TF EQQ, NE)
2158 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2159 DoubleLtOp -> (FCMP TF LTT, NE)
2160 DoubleLeOp -> (FCMP TF LE, NE)
2162 genCondJump lbl (StPrim op [x, y])
2163 = trivialCode instr x y `thenNat` \ register ->
2164 getNewRegNCG IntRep `thenNat` \ tmp ->
2166 code = registerCode register tmp
2167 result = registerName register tmp
2168 target = ImmCLbl lbl
2170 returnNat (code . mkSeqInstr (BI cond result target))
2172 (instr, cond) = case op of
2173 CharGtOp -> (CMP LE, EQQ)
2174 CharGeOp -> (CMP LTT, EQQ)
2175 CharEqOp -> (CMP EQQ, NE)
2176 CharNeOp -> (CMP EQQ, EQQ)
2177 CharLtOp -> (CMP LTT, NE)
2178 CharLeOp -> (CMP LE, NE)
2179 IntGtOp -> (CMP LE, EQQ)
2180 IntGeOp -> (CMP LTT, EQQ)
2181 IntEqOp -> (CMP EQQ, NE)
2182 IntNeOp -> (CMP EQQ, EQQ)
2183 IntLtOp -> (CMP LTT, NE)
2184 IntLeOp -> (CMP LE, NE)
2185 WordGtOp -> (CMP ULE, EQQ)
2186 WordGeOp -> (CMP ULT, EQQ)
2187 WordEqOp -> (CMP EQQ, NE)
2188 WordNeOp -> (CMP EQQ, EQQ)
2189 WordLtOp -> (CMP ULT, NE)
2190 WordLeOp -> (CMP ULE, NE)
2191 AddrGtOp -> (CMP ULE, EQQ)
2192 AddrGeOp -> (CMP ULT, EQQ)
2193 AddrEqOp -> (CMP EQQ, NE)
2194 AddrNeOp -> (CMP EQQ, EQQ)
2195 AddrLtOp -> (CMP ULT, NE)
2196 AddrLeOp -> (CMP ULE, NE)
2198 #endif {- alpha_TARGET_ARCH -}
2199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2200 #if i386_TARGET_ARCH
2202 genCondJump lbl bool
2203 = getCondCode bool `thenNat` \ condition ->
2205 code = condCode condition
2206 cond = condName condition
2208 returnNat (code `snocOL` JXX cond lbl)
2210 #endif {- i386_TARGET_ARCH -}
2211 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2212 #if sparc_TARGET_ARCH
2214 genCondJump lbl bool
2215 = getCondCode bool `thenNat` \ condition ->
2217 code = condCode condition
2218 cond = condName condition
2219 target = ImmCLbl lbl
2224 if condFloat condition
2225 then [NOP, BF cond False target, NOP]
2226 else [BI cond False target, NOP]
2230 #endif {- sparc_TARGET_ARCH -}
2233 %************************************************************************
2235 \subsection{Generating C calls}
2237 %************************************************************************
2239 Now the biggest nightmare---calls. Most of the nastiness is buried in
2240 @get_arg@, which moves the arguments to the correct registers/stack
2241 locations. Apart from that, the code is easy.
2243 (If applicable) Do not fill the delay slots here; you will confuse the
2248 :: FAST_STRING -- function to call
2250 -> PrimRep -- type of the result
2251 -> [StixTree] -- arguments (of mixed type)
2254 #if alpha_TARGET_ARCH
2256 genCCall fn cconv kind args
2257 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2258 `thenNat` \ ((unused,_), argCode) ->
2260 nRegs = length allArgRegs - length unused
2261 code = asmSeqThen (map ($ []) argCode)
2264 LDA pv (AddrImm (ImmLab (ptext fn))),
2265 JSR ra (AddrReg pv) nRegs,
2266 LDGP gp (AddrReg ra)]
2268 ------------------------
2269 {- Try to get a value into a specific register (or registers) for
2270 a call. The first 6 arguments go into the appropriate
2271 argument register (separate registers for integer and floating
2272 point arguments, but used in lock-step), and the remaining
2273 arguments are dumped to the stack, beginning at 0(sp). Our
2274 first argument is a pair of the list of remaining argument
2275 registers to be assigned for this call and the next stack
2276 offset to use for overflowing arguments. This way,
2277 @get_Arg@ can be applied to all of a call's arguments using
2281 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2282 -> StixTree -- Current argument
2283 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2285 -- We have to use up all of our argument registers first...
2287 get_arg ((iDst,fDst):dsts, offset) arg
2288 = getRegister arg `thenNat` \ register ->
2290 reg = if isFloatingRep pk then fDst else iDst
2291 code = registerCode register reg
2292 src = registerName register reg
2293 pk = registerRep register
2296 if isFloatingRep pk then
2297 ((dsts, offset), if isFixed register then
2298 code . mkSeqInstr (FMOV src fDst)
2301 ((dsts, offset), if isFixed register then
2302 code . mkSeqInstr (OR src (RIReg src) iDst)
2305 -- Once we have run out of argument registers, we move to the
2308 get_arg ([], offset) arg
2309 = getRegister arg `thenNat` \ register ->
2310 getNewRegNCG (registerRep register)
2313 code = registerCode register tmp
2314 src = registerName register tmp
2315 pk = registerRep register
2316 sz = primRepToSize pk
2318 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2320 #endif {- alpha_TARGET_ARCH -}
2321 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2322 #if i386_TARGET_ARCH
2324 genCCall fn cconv kind [StInt i]
2325 | fn == SLIT ("PerformGC_wrapper")
2327 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2328 CALL (ImmLit (ptext (if underscorePrefix
2329 then (SLIT ("_PerformGC_wrapper"))
2330 else (SLIT ("PerformGC_wrapper")))))
2336 genCCall fn cconv kind args
2337 = mapNat get_call_arg
2338 (reverse args) `thenNat` \ sizes_n_codes ->
2339 getDeltaNat `thenNat` \ delta ->
2340 let (sizes, codes) = unzip sizes_n_codes
2341 tot_arg_size = sum sizes
2342 code2 = concatOL codes
2344 [CALL (fn__2 tot_arg_size)]
2346 (if cconv == stdCallConv then [] else
2347 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2349 [DELTA (delta + tot_arg_size)]
2352 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2353 returnNat (code2 `appOL` 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) ???
2363 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2365 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2367 stdcallsize tot_arg_size
2368 | cconv == stdCallConv = '@':show tot_arg_size
2376 get_call_arg :: StixTree{-current argument-}
2377 -> NatM (Int, InstrBlock) -- argsz, code
2380 = get_op arg `thenNat` \ (code, reg, sz) ->
2381 getDeltaNat `thenNat` \ delta ->
2382 arg_size sz `bind` \ size ->
2383 setDeltaNat (delta-size) `thenNat` \ _ ->
2384 if (case sz of DF -> True; F -> True; _ -> False)
2385 then returnNat (size,
2387 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2389 GST sz reg (AddrBaseIndex (Just esp)
2393 else returnNat (size,
2395 PUSH L (OpReg reg) `snocOL`
2401 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2404 = getRegister op `thenNat` \ register ->
2405 getNewRegNCG (registerRep register)
2408 code = registerCode register tmp
2409 reg = registerName register tmp
2410 pk = registerRep register
2411 sz = primRepToSize pk
2413 returnNat (code, reg, sz)
2415 #endif {- i386_TARGET_ARCH -}
2416 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2417 #if sparc_TARGET_ARCH
2419 The SPARC calling convention is an absolute
2420 nightmare. The first 6x32 bits of arguments are mapped into
2421 %o0 through %o5, and the remaining arguments are dumped to the
2422 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2424 If we have to put args on the stack, move %o6==%sp down by
2425 the number of words to go on the stack, to ensure there's enough space.
2427 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2428 16 words above the stack pointer is a word for the address of
2429 a structure return value. I use this as a temporary location
2430 for moving values from float to int regs. Certainly it isn't
2431 safe to put anything in the 16 words starting at %sp, since
2432 this area can get trashed at any time due to window overflows
2433 caused by signal handlers.
2435 A final complication (if the above isn't enough) is that
2436 we can't blithely calculate the arguments one by one into
2437 %o0 .. %o5. Consider the following nested calls:
2441 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2442 the inner call will itself use %o0, which trashes the value put there
2443 in preparation for the outer call. Upshot: we need to calculate the
2444 args into temporary regs, and move those to arg regs or onto the
2445 stack only immediately prior to the call proper. Sigh.
2448 genCCall fn cconv kind args
2449 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2450 let (argcodes, vregss) = unzip argcode_and_vregs
2451 argcode = concatOL argcodes
2452 vregs = concat vregss
2453 n_argRegs = length allArgRegs
2454 n_argRegs_used = min (length vregs) n_argRegs
2455 (move_sp_down, move_sp_up)
2456 = let nn = length vregs - n_argRegs
2457 + 1 -- (for the road)
2460 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2462 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2464 = unitOL (CALL fn__2 n_argRegs_used False)
2466 returnNat (argcode `appOL`
2467 move_sp_down `appOL`
2468 transfer_code `appOL`
2473 -- function names that begin with '.' are assumed to be special
2474 -- internally generated names like '.mul,' which don't get an
2475 -- underscore prefix
2476 -- ToDo:needed (WDP 96/03) ???
2477 fn__2 = case (_HEAD_ fn) of
2478 '.' -> ImmLit (ptext fn)
2479 _ -> ImmLab False (ptext fn)
2481 -- move args from the integer vregs into which they have been
2482 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2483 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2485 move_final [] _ offset -- all args done
2488 move_final (v:vs) [] offset -- out of aregs; move to stack
2489 = ST W v (spRel offset)
2490 : move_final vs [] (offset+1)
2492 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2493 = OR False g0 (RIReg v) a
2494 : move_final vs az offset
2496 -- generate code to calculate an argument, and move it into one
2497 -- or two integer vregs.
2498 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2499 arg_to_int_vregs arg
2500 = getRegister arg `thenNat` \ register ->
2501 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2502 let code = registerCode register tmp
2503 src = registerName register tmp
2504 pk = registerRep register
2506 -- the value is in src. Get it into 1 or 2 int vregs.
2509 getNewRegNCG WordRep `thenNat` \ v1 ->
2510 getNewRegNCG WordRep `thenNat` \ v2 ->
2513 FMOV DF src f0 `snocOL`
2514 ST F f0 (spRel 16) `snocOL`
2515 LD W (spRel 16) v1 `snocOL`
2516 ST F (fPair f0) (spRel 16) `snocOL`
2522 getNewRegNCG WordRep `thenNat` \ v1 ->
2525 ST F src (spRel 16) `snocOL`
2531 getNewRegNCG WordRep `thenNat` \ v1 ->
2533 code `snocOL` OR False g0 (RIReg src) v1
2537 #endif {- sparc_TARGET_ARCH -}
2540 %************************************************************************
2542 \subsection{Support bits}
2544 %************************************************************************
2546 %************************************************************************
2548 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2550 %************************************************************************
2552 Turn those condition codes into integers now (when they appear on
2553 the right hand side of an assignment).
2555 (If applicable) Do not fill the delay slots here; you will confuse the
2559 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2561 #if alpha_TARGET_ARCH
2562 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2563 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2564 #endif {- alpha_TARGET_ARCH -}
2566 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2567 #if i386_TARGET_ARCH
2570 = condIntCode cond x y `thenNat` \ condition ->
2571 getNewRegNCG IntRep `thenNat` \ tmp ->
2573 code = condCode condition
2574 cond = condName condition
2575 code__2 dst = code `appOL` toOL [
2576 SETCC cond (OpReg tmp),
2577 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2578 MOV L (OpReg tmp) (OpReg dst)]
2580 returnNat (Any IntRep code__2)
2583 = getNatLabelNCG `thenNat` \ lbl1 ->
2584 getNatLabelNCG `thenNat` \ lbl2 ->
2585 condFltCode cond x y `thenNat` \ condition ->
2587 code = condCode condition
2588 cond = condName condition
2589 code__2 dst = code `appOL` toOL [
2591 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2594 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2597 returnNat (Any IntRep code__2)
2599 #endif {- i386_TARGET_ARCH -}
2600 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2601 #if sparc_TARGET_ARCH
2603 condIntReg EQQ x (StInt 0)
2604 = getRegister x `thenNat` \ register ->
2605 getNewRegNCG IntRep `thenNat` \ tmp ->
2607 code = registerCode register tmp
2608 src = registerName register tmp
2609 code__2 dst = code `appOL` toOL [
2610 SUB False True g0 (RIReg src) g0,
2611 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2613 returnNat (Any IntRep code__2)
2616 = getRegister x `thenNat` \ register1 ->
2617 getRegister y `thenNat` \ register2 ->
2618 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2619 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2621 code1 = registerCode register1 tmp1
2622 src1 = registerName register1 tmp1
2623 code2 = registerCode register2 tmp2
2624 src2 = registerName register2 tmp2
2625 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2626 XOR False src1 (RIReg src2) dst,
2627 SUB False True g0 (RIReg dst) g0,
2628 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2630 returnNat (Any IntRep code__2)
2632 condIntReg NE x (StInt 0)
2633 = getRegister x `thenNat` \ register ->
2634 getNewRegNCG IntRep `thenNat` \ tmp ->
2636 code = registerCode register tmp
2637 src = registerName register tmp
2638 code__2 dst = code `appOL` toOL [
2639 SUB False True g0 (RIReg src) g0,
2640 ADD True False g0 (RIImm (ImmInt 0)) dst]
2642 returnNat (Any IntRep code__2)
2645 = getRegister x `thenNat` \ register1 ->
2646 getRegister y `thenNat` \ register2 ->
2647 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2648 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2650 code1 = registerCode register1 tmp1
2651 src1 = registerName register1 tmp1
2652 code2 = registerCode register2 tmp2
2653 src2 = registerName register2 tmp2
2654 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2655 XOR False src1 (RIReg src2) dst,
2656 SUB False True g0 (RIReg dst) g0,
2657 ADD True False g0 (RIImm (ImmInt 0)) dst]
2659 returnNat (Any IntRep code__2)
2662 = getNatLabelNCG `thenNat` \ lbl1 ->
2663 getNatLabelNCG `thenNat` \ lbl2 ->
2664 condIntCode cond x y `thenNat` \ condition ->
2666 code = condCode condition
2667 cond = condName condition
2668 code__2 dst = code `appOL` toOL [
2669 BI cond False (ImmCLbl lbl1), NOP,
2670 OR False g0 (RIImm (ImmInt 0)) dst,
2671 BI ALWAYS False (ImmCLbl lbl2), NOP,
2673 OR False g0 (RIImm (ImmInt 1)) dst,
2676 returnNat (Any IntRep code__2)
2679 = getNatLabelNCG `thenNat` \ lbl1 ->
2680 getNatLabelNCG `thenNat` \ lbl2 ->
2681 condFltCode cond x y `thenNat` \ condition ->
2683 code = condCode condition
2684 cond = condName condition
2685 code__2 dst = code `appOL` toOL [
2687 BF cond False (ImmCLbl lbl1), NOP,
2688 OR False g0 (RIImm (ImmInt 0)) dst,
2689 BI ALWAYS False (ImmCLbl lbl2), NOP,
2691 OR False g0 (RIImm (ImmInt 1)) dst,
2694 returnNat (Any IntRep code__2)
2696 #endif {- sparc_TARGET_ARCH -}
2699 %************************************************************************
2701 \subsubsection{@trivial*Code@: deal with trivial instructions}
2703 %************************************************************************
2705 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2706 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2707 for constants on the right hand side, because that's where the generic
2708 optimizer will have put them.
2710 Similarly, for unary instructions, we don't have to worry about
2711 matching an StInt as the argument, because genericOpt will already
2712 have handled the constant-folding.
2716 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2717 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2718 -> Maybe (Operand -> Operand -> Instr)
2719 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2721 -> StixTree -> StixTree -- the two arguments
2726 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2727 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2728 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2730 -> StixTree -> StixTree -- the two arguments
2734 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2735 ,IF_ARCH_i386 ((Operand -> Instr)
2736 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2738 -> StixTree -- the one argument
2743 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2744 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2745 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2747 -> StixTree -- the one argument
2750 #if alpha_TARGET_ARCH
2752 trivialCode instr x (StInt y)
2754 = getRegister x `thenNat` \ register ->
2755 getNewRegNCG IntRep `thenNat` \ tmp ->
2757 code = registerCode register tmp
2758 src1 = registerName register tmp
2759 src2 = ImmInt (fromInteger y)
2760 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2762 returnNat (Any IntRep code__2)
2764 trivialCode instr x y
2765 = getRegister x `thenNat` \ register1 ->
2766 getRegister y `thenNat` \ register2 ->
2767 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2768 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2770 code1 = registerCode register1 tmp1 []
2771 src1 = registerName register1 tmp1
2772 code2 = registerCode register2 tmp2 []
2773 src2 = registerName register2 tmp2
2774 code__2 dst = asmSeqThen [code1, code2] .
2775 mkSeqInstr (instr src1 (RIReg src2) dst)
2777 returnNat (Any IntRep code__2)
2780 trivialUCode instr x
2781 = getRegister x `thenNat` \ register ->
2782 getNewRegNCG IntRep `thenNat` \ tmp ->
2784 code = registerCode register tmp
2785 src = registerName register tmp
2786 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2788 returnNat (Any IntRep code__2)
2791 trivialFCode _ instr x y
2792 = getRegister x `thenNat` \ register1 ->
2793 getRegister y `thenNat` \ register2 ->
2794 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2795 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2797 code1 = registerCode register1 tmp1
2798 src1 = registerName register1 tmp1
2800 code2 = registerCode register2 tmp2
2801 src2 = registerName register2 tmp2
2803 code__2 dst = asmSeqThen [code1 [], code2 []] .
2804 mkSeqInstr (instr src1 src2 dst)
2806 returnNat (Any DoubleRep code__2)
2808 trivialUFCode _ instr x
2809 = getRegister x `thenNat` \ register ->
2810 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2812 code = registerCode register tmp
2813 src = registerName register tmp
2814 code__2 dst = code . mkSeqInstr (instr src dst)
2816 returnNat (Any DoubleRep code__2)
2818 #endif {- alpha_TARGET_ARCH -}
2819 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2820 #if i386_TARGET_ARCH
2822 The Rules of the Game are:
2824 * You cannot assume anything about the destination register dst;
2825 it may be anything, including a fixed reg.
2827 * You may compute an operand into a fixed reg, but you may not
2828 subsequently change the contents of that fixed reg. If you
2829 want to do so, first copy the value either to a temporary
2830 or into dst. You are free to modify dst even if it happens
2831 to be a fixed reg -- that's not your problem.
2833 * You cannot assume that a fixed reg will stay live over an
2834 arbitrary computation. The same applies to the dst reg.
2836 * Temporary regs obtained from getNewRegNCG are distinct from
2837 each other and from all other regs, and stay live over
2838 arbitrary computations.
2842 trivialCode instr maybe_revinstr a b
2845 = getRegister a `thenNat` \ rega ->
2848 then registerCode rega dst `bind` \ code_a ->
2850 instr (OpImm imm_b) (OpReg dst)
2851 else registerCodeF rega `bind` \ code_a ->
2852 registerNameF rega `bind` \ r_a ->
2854 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2855 instr (OpImm imm_b) (OpReg dst)
2857 returnNat (Any IntRep mkcode)
2860 = getRegister b `thenNat` \ regb ->
2861 getNewRegNCG IntRep `thenNat` \ tmp ->
2862 let revinstr_avail = maybeToBool maybe_revinstr
2863 revinstr = case maybe_revinstr of Just ri -> ri
2867 then registerCode regb dst `bind` \ code_b ->
2869 revinstr (OpImm imm_a) (OpReg dst)
2870 else registerCodeF regb `bind` \ code_b ->
2871 registerNameF regb `bind` \ r_b ->
2873 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2874 revinstr (OpImm imm_a) (OpReg dst)
2878 then registerCode regb tmp `bind` \ code_b ->
2880 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2881 instr (OpReg tmp) (OpReg dst)
2882 else registerCodeF regb `bind` \ code_b ->
2883 registerNameF regb `bind` \ r_b ->
2885 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2886 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2887 instr (OpReg tmp) (OpReg dst)
2889 returnNat (Any IntRep mkcode)
2892 = getRegister a `thenNat` \ rega ->
2893 getRegister b `thenNat` \ regb ->
2894 getNewRegNCG IntRep `thenNat` \ tmp ->
2896 = case (isAny rega, isAny regb) of
2898 -> registerCode regb tmp `bind` \ code_b ->
2899 registerCode rega dst `bind` \ code_a ->
2902 instr (OpReg tmp) (OpReg dst)
2904 -> registerCode rega tmp `bind` \ code_a ->
2905 registerCodeF regb `bind` \ code_b ->
2906 registerNameF regb `bind` \ r_b ->
2909 instr (OpReg r_b) (OpReg tmp) `snocOL`
2910 MOV L (OpReg tmp) (OpReg dst)
2912 -> registerCode regb tmp `bind` \ code_b ->
2913 registerCodeF rega `bind` \ code_a ->
2914 registerNameF rega `bind` \ r_a ->
2917 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2918 instr (OpReg tmp) (OpReg dst)
2920 -> registerCodeF rega `bind` \ code_a ->
2921 registerNameF rega `bind` \ r_a ->
2922 registerCodeF regb `bind` \ code_b ->
2923 registerNameF regb `bind` \ r_b ->
2925 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2927 instr (OpReg r_b) (OpReg tmp) `snocOL`
2928 MOV L (OpReg tmp) (OpReg dst)
2930 returnNat (Any IntRep mkcode)
2933 maybe_imm_a = maybeImm a
2934 is_imm_a = maybeToBool maybe_imm_a
2935 imm_a = case maybe_imm_a of Just imm -> imm
2937 maybe_imm_b = maybeImm b
2938 is_imm_b = maybeToBool maybe_imm_b
2939 imm_b = case maybe_imm_b of Just imm -> imm
2943 trivialUCode instr x
2944 = getRegister x `thenNat` \ register ->
2946 code__2 dst = let code = registerCode register dst
2947 src = registerName register dst
2949 if isFixed register && dst /= src
2950 then toOL [MOV L (OpReg src) (OpReg dst),
2952 else unitOL (instr (OpReg src))
2954 returnNat (Any IntRep code__2)
2957 trivialFCode pk instr x y
2958 = getRegister x `thenNat` \ register1 ->
2959 getRegister y `thenNat` \ register2 ->
2960 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2961 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2963 code1 = registerCode register1 tmp1
2964 src1 = registerName register1 tmp1
2966 code2 = registerCode register2 tmp2
2967 src2 = registerName register2 tmp2
2970 -- treat the common case specially: both operands in
2972 | isAny register1 && isAny register2
2975 instr (primRepToSize pk) src1 src2 dst
2977 -- be paranoid (and inefficient)
2979 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2981 instr (primRepToSize pk) tmp1 src2 dst
2983 returnNat (Any pk code__2)
2987 trivialUFCode pk instr x
2988 = getRegister x `thenNat` \ register ->
2989 getNewRegNCG pk `thenNat` \ tmp ->
2991 code = registerCode register tmp
2992 src = registerName register tmp
2993 code__2 dst = code `snocOL` instr src dst
2995 returnNat (Any pk code__2)
2997 #endif {- i386_TARGET_ARCH -}
2998 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2999 #if sparc_TARGET_ARCH
3001 trivialCode instr x (StInt y)
3003 = getRegister x `thenNat` \ register ->
3004 getNewRegNCG IntRep `thenNat` \ tmp ->
3006 code = registerCode register tmp
3007 src1 = registerName register tmp
3008 src2 = ImmInt (fromInteger y)
3009 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3011 returnNat (Any IntRep code__2)
3013 trivialCode instr x y
3014 = getRegister x `thenNat` \ register1 ->
3015 getRegister y `thenNat` \ register2 ->
3016 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3017 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3019 code1 = registerCode register1 tmp1
3020 src1 = registerName register1 tmp1
3021 code2 = registerCode register2 tmp2
3022 src2 = registerName register2 tmp2
3023 code__2 dst = code1 `appOL` code2 `snocOL`
3024 instr src1 (RIReg src2) dst
3026 returnNat (Any IntRep code__2)
3029 trivialFCode pk instr x y
3030 = getRegister x `thenNat` \ register1 ->
3031 getRegister y `thenNat` \ register2 ->
3032 getNewRegNCG (registerRep register1)
3034 getNewRegNCG (registerRep register2)
3036 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3038 promote x = FxTOy F DF x tmp
3040 pk1 = registerRep register1
3041 code1 = registerCode register1 tmp1
3042 src1 = registerName register1 tmp1
3044 pk2 = registerRep register2
3045 code2 = registerCode register2 tmp2
3046 src2 = registerName register2 tmp2
3050 code1 `appOL` code2 `snocOL`
3051 instr (primRepToSize pk) src1 src2 dst
3052 else if pk1 == FloatRep then
3053 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3054 instr DF tmp src2 dst
3056 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3057 instr DF src1 tmp dst
3059 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3062 trivialUCode instr x
3063 = getRegister x `thenNat` \ register ->
3064 getNewRegNCG IntRep `thenNat` \ tmp ->
3066 code = registerCode register tmp
3067 src = registerName register tmp
3068 code__2 dst = code `snocOL` instr (RIReg src) dst
3070 returnNat (Any IntRep code__2)
3073 trivialUFCode pk instr x
3074 = getRegister x `thenNat` \ register ->
3075 getNewRegNCG pk `thenNat` \ tmp ->
3077 code = registerCode register tmp
3078 src = registerName register tmp
3079 code__2 dst = code `snocOL` instr src dst
3081 returnNat (Any pk code__2)
3083 #endif {- sparc_TARGET_ARCH -}
3086 %************************************************************************
3088 \subsubsection{Coercing to/from integer/floating-point...}
3090 %************************************************************************
3092 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3093 to be generated. Here we just change the type on the Register passed
3094 on up. The code is machine-independent.
3096 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3097 conversions. We have to store temporaries in memory to move
3098 between the integer and the floating point register sets.
3101 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3102 coerceFltCode :: StixTree -> NatM Register
3104 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3105 coerceFP2Int :: StixTree -> NatM Register
3108 = getRegister x `thenNat` \ register ->
3111 Fixed _ reg code -> Fixed pk reg code
3112 Any _ code -> Any pk code
3117 = getRegister x `thenNat` \ register ->
3120 Fixed _ reg code -> Fixed DoubleRep reg code
3121 Any _ code -> Any DoubleRep code
3126 #if alpha_TARGET_ARCH
3129 = getRegister x `thenNat` \ register ->
3130 getNewRegNCG IntRep `thenNat` \ reg ->
3132 code = registerCode register reg
3133 src = registerName register reg
3135 code__2 dst = code . mkSeqInstrs [
3137 LD TF dst (spRel 0),
3140 returnNat (Any DoubleRep code__2)
3144 = getRegister x `thenNat` \ register ->
3145 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3147 code = registerCode register tmp
3148 src = registerName register tmp
3150 code__2 dst = code . mkSeqInstrs [
3152 ST TF tmp (spRel 0),
3155 returnNat (Any IntRep code__2)
3157 #endif {- alpha_TARGET_ARCH -}
3158 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3159 #if i386_TARGET_ARCH
3162 = getRegister x `thenNat` \ register ->
3163 getNewRegNCG IntRep `thenNat` \ reg ->
3165 code = registerCode register reg
3166 src = registerName register reg
3167 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3168 code__2 dst = code `snocOL` opc src dst
3170 returnNat (Any pk code__2)
3174 = getRegister x `thenNat` \ register ->
3175 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3177 code = registerCode register tmp
3178 src = registerName register tmp
3179 pk = registerRep register
3181 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3182 code__2 dst = code `snocOL` opc src dst
3184 returnNat (Any IntRep code__2)
3186 #endif {- i386_TARGET_ARCH -}
3187 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3188 #if sparc_TARGET_ARCH
3191 = getRegister x `thenNat` \ register ->
3192 getNewRegNCG IntRep `thenNat` \ reg ->
3194 code = registerCode register reg
3195 src = registerName register reg
3197 code__2 dst = code `appOL` toOL [
3198 ST W src (spRel (-2)),
3199 LD W (spRel (-2)) dst,
3200 FxTOy W (primRepToSize pk) dst dst]
3202 returnNat (Any pk code__2)
3206 = getRegister x `thenNat` \ register ->
3207 getNewRegNCG IntRep `thenNat` \ reg ->
3208 getNewRegNCG FloatRep `thenNat` \ tmp ->
3210 code = registerCode register reg
3211 src = registerName register reg
3212 pk = registerRep register
3214 code__2 dst = code `appOL` toOL [
3215 FxTOy (primRepToSize pk) W src tmp,
3216 ST W tmp (spRel (-2)),
3217 LD W (spRel (-2)) dst]
3219 returnNat (Any IntRep code__2)
3221 #endif {- sparc_TARGET_ARCH -}
3224 %************************************************************************
3226 \subsubsection{Coercing integer to @Char@...}
3228 %************************************************************************
3230 Integer to character conversion.
3233 chrCode :: StixTree -> NatM Register
3235 #if alpha_TARGET_ARCH
3237 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3238 -- It should coerce a 64-bit value to a 32-bit value.
3241 = getRegister x `thenNat` \ register ->
3242 getNewRegNCG IntRep `thenNat` \ reg ->
3244 code = registerCode register reg
3245 src = registerName register reg
3246 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3248 returnNat (Any IntRep code__2)
3250 #endif {- alpha_TARGET_ARCH -}
3251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3252 #if i386_TARGET_ARCH
3255 = getRegister x `thenNat` \ register ->
3258 Fixed _ reg code -> Fixed IntRep reg code
3259 Any _ code -> Any IntRep code
3262 #endif {- i386_TARGET_ARCH -}
3263 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3264 #if sparc_TARGET_ARCH
3267 = getRegister x `thenNat` \ register ->
3270 Fixed _ reg code -> Fixed IntRep reg code
3271 Any _ code -> Any IntRep code
3274 #endif {- sparc_TARGET_ARCH -}