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 AbsCSyn ( MagicId )
22 import AbsCUtils ( magicIdPrimRep )
23 import CallConv ( CallConv )
24 import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
25 import Maybes ( maybeToBool, expectJust )
26 import PrimRep ( isFloatingRep, PrimRep(..) )
27 import PrimOp ( PrimOp(..) )
28 import CallConv ( cCallConv )
29 import Stix ( getNatLabelNCG, StixTree(..),
30 StixReg(..), CodeSegment(..),
31 pprStixTree, ppStixReg,
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 arg -> genJump (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 (StCLbl l) = returnNat (nilOL, ImmCLbl l)
99 getData (StString s) =
100 getNatLabelNCG `thenNat` \ lbl ->
101 returnNat (toOL [LABEL lbl,
102 ASCII True (_UNPK_ s)],
104 -- the linker can handle simple arithmetic...
105 getData (StIndex rep (StCLbl lbl) (StInt off)) =
107 ImmIndex lbl (fromInteger (off * sizeOf rep)))
109 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
110 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
111 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
113 derefDLL :: StixTree -> StixTree
115 | opt_Static -- short out the entire deal if not doing DLLs
122 StCLbl lbl -> if labelDynamic lbl
123 then StInd PtrRep (StCLbl lbl)
125 -- all the rest are boring
126 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
127 StPrim pk args -> StPrim pk (map qq args)
128 StInd pk addr -> StInd pk (qq addr)
129 StCall who cc pk args -> StCall who cc pk (map qq args)
135 _ -> pprPanic "derefDLL: unhandled case"
139 %************************************************************************
141 \subsection{General things for putting together code sequences}
143 %************************************************************************
146 mangleIndexTree :: StixTree -> StixTree
148 mangleIndexTree (StIndex pk base (StInt i))
149 = StPrim IntAddOp [base, off]
151 off = StInt (i * sizeOf pk)
153 mangleIndexTree (StIndex pk base off)
157 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
158 if s == 0 then off else StPrim SllOp [off, StInt s]
161 shift DoubleRep = 3::Integer
162 shift CharRep = 0::Integer
163 shift _ = IF_ARCH_alpha(3,2)
167 maybeImm :: StixTree -> Maybe Imm
171 maybeImm (StIndex rep (StCLbl l) (StInt off))
172 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
174 | i >= toInteger minInt && i <= toInteger maxInt
175 = Just (ImmInt (fromInteger i))
177 = Just (ImmInteger i)
182 %************************************************************************
184 \subsection{The @Register@ type}
186 %************************************************************************
188 @Register@s passed up the tree. If the stix code forces the register
189 to live in a pre-decided machine register, it comes out as @Fixed@;
190 otherwise, it comes out as @Any@, and the parent can decide which
191 register to put it in.
195 = Fixed PrimRep Reg InstrBlock
196 | Any PrimRep (Reg -> InstrBlock)
198 registerCode :: Register -> Reg -> InstrBlock
199 registerCode (Fixed _ _ code) reg = code
200 registerCode (Any _ code) reg = code reg
202 registerCodeF (Fixed _ _ code) = code
203 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
205 registerCodeA (Any _ code) = code
206 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
208 registerName :: Register -> Reg -> Reg
209 registerName (Fixed _ reg _) _ = reg
210 registerName (Any _ _) reg = reg
212 registerNameF (Fixed _ reg _) = reg
213 registerNameF (Any _ _) = pprPanic "registerNameF" empty
215 registerRep :: Register -> PrimRep
216 registerRep (Fixed pk _ _) = pk
217 registerRep (Any pk _) = pk
219 {-# INLINE registerCode #-}
220 {-# INLINE registerCodeF #-}
221 {-# INLINE registerName #-}
222 {-# INLINE registerNameF #-}
223 {-# INLINE registerRep #-}
224 {-# INLINE isFixed #-}
227 isFixed, isAny :: Register -> Bool
228 isFixed (Fixed _ _ _) = True
229 isFixed (Any _ _) = False
231 isAny = not . isFixed
234 Generate code to get a subtree into a @Register@:
236 getRegister :: StixTree -> NatM Register
238 getRegister (StReg (StixMagicId stgreg))
239 = case (magicIdRegMaybe stgreg) of
240 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
243 getRegister (StReg (StixTemp u pk))
244 = returnNat (Fixed pk (mkVReg u pk) nilOL)
246 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
248 getRegister (StCall fn cconv kind args)
249 = genCCall fn cconv kind args `thenNat` \ call ->
250 returnNat (Fixed kind reg call)
252 reg = if isFloatingRep kind
253 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
254 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
256 getRegister (StString s)
257 = getNatLabelNCG `thenNat` \ lbl ->
259 imm_lbl = ImmCLbl lbl
264 ASCII True (_UNPK_ s),
266 #if alpha_TARGET_ARCH
267 LDA dst (AddrImm imm_lbl)
270 MOV L (OpImm imm_lbl) (OpReg dst)
272 #if sparc_TARGET_ARCH
273 SETHI (HI imm_lbl) dst,
274 OR False dst (RIImm (LO imm_lbl)) dst
278 returnNat (Any PtrRep code)
282 -- end of machine-"independent" bit; here we go on the rest...
284 #if alpha_TARGET_ARCH
286 getRegister (StDouble d)
287 = getNatLabelNCG `thenNat` \ lbl ->
288 getNewRegNCG PtrRep `thenNat` \ tmp ->
289 let code dst = mkSeqInstrs [
292 DATA TF [ImmLab (rational d)],
294 LDA tmp (AddrImm (ImmCLbl lbl)),
295 LD TF dst (AddrReg tmp)]
297 returnNat (Any DoubleRep code)
299 getRegister (StPrim primop [x]) -- unary PrimOps
301 IntNegOp -> trivialUCode (NEG Q False) x
303 NotOp -> trivialUCode NOT x
305 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
306 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
308 OrdOp -> coerceIntCode IntRep x
311 Float2IntOp -> coerceFP2Int x
312 Int2FloatOp -> coerceInt2FP pr x
313 Double2IntOp -> coerceFP2Int x
314 Int2DoubleOp -> coerceInt2FP pr x
316 Double2FloatOp -> coerceFltCode x
317 Float2DoubleOp -> coerceFltCode x
319 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
321 fn = case other_op of
322 FloatExpOp -> SLIT("exp")
323 FloatLogOp -> SLIT("log")
324 FloatSqrtOp -> SLIT("sqrt")
325 FloatSinOp -> SLIT("sin")
326 FloatCosOp -> SLIT("cos")
327 FloatTanOp -> SLIT("tan")
328 FloatAsinOp -> SLIT("asin")
329 FloatAcosOp -> SLIT("acos")
330 FloatAtanOp -> SLIT("atan")
331 FloatSinhOp -> SLIT("sinh")
332 FloatCoshOp -> SLIT("cosh")
333 FloatTanhOp -> SLIT("tanh")
334 DoubleExpOp -> SLIT("exp")
335 DoubleLogOp -> SLIT("log")
336 DoubleSqrtOp -> SLIT("sqrt")
337 DoubleSinOp -> SLIT("sin")
338 DoubleCosOp -> SLIT("cos")
339 DoubleTanOp -> SLIT("tan")
340 DoubleAsinOp -> SLIT("asin")
341 DoubleAcosOp -> SLIT("acos")
342 DoubleAtanOp -> SLIT("atan")
343 DoubleSinhOp -> SLIT("sinh")
344 DoubleCoshOp -> SLIT("cosh")
345 DoubleTanhOp -> SLIT("tanh")
347 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
349 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
351 CharGtOp -> trivialCode (CMP LTT) y x
352 CharGeOp -> trivialCode (CMP LE) y x
353 CharEqOp -> trivialCode (CMP EQQ) x y
354 CharNeOp -> int_NE_code x y
355 CharLtOp -> trivialCode (CMP LTT) x y
356 CharLeOp -> trivialCode (CMP LE) x y
358 IntGtOp -> trivialCode (CMP LTT) y x
359 IntGeOp -> trivialCode (CMP LE) y x
360 IntEqOp -> trivialCode (CMP EQQ) x y
361 IntNeOp -> int_NE_code x y
362 IntLtOp -> trivialCode (CMP LTT) x y
363 IntLeOp -> trivialCode (CMP LE) x y
365 WordGtOp -> trivialCode (CMP ULT) y x
366 WordGeOp -> trivialCode (CMP ULE) x y
367 WordEqOp -> trivialCode (CMP EQQ) x y
368 WordNeOp -> int_NE_code x y
369 WordLtOp -> trivialCode (CMP ULT) x y
370 WordLeOp -> trivialCode (CMP ULE) x y
372 AddrGtOp -> trivialCode (CMP ULT) y x
373 AddrGeOp -> trivialCode (CMP ULE) y x
374 AddrEqOp -> trivialCode (CMP EQQ) x y
375 AddrNeOp -> int_NE_code x y
376 AddrLtOp -> trivialCode (CMP ULT) x y
377 AddrLeOp -> trivialCode (CMP ULE) x y
379 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
380 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
381 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
382 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
383 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
384 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
386 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
387 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
388 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
389 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
390 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
391 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
393 IntAddOp -> trivialCode (ADD Q False) x y
394 IntSubOp -> trivialCode (SUB Q False) x y
395 IntMulOp -> trivialCode (MUL Q False) x y
396 IntQuotOp -> trivialCode (DIV Q False) x y
397 IntRemOp -> trivialCode (REM Q False) x y
399 WordQuotOp -> trivialCode (DIV Q True) x y
400 WordRemOp -> trivialCode (REM Q True) x y
402 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
403 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
404 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
405 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
407 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
408 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
409 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
410 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
412 AndOp -> trivialCode AND x y
413 OrOp -> trivialCode OR x y
414 XorOp -> trivialCode XOR x y
415 SllOp -> trivialCode SLL x y
416 SrlOp -> trivialCode SRL x y
418 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
419 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
420 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
422 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
423 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
425 {- ------------------------------------------------------------
426 Some bizarre special code for getting condition codes into
427 registers. Integer non-equality is a test for equality
428 followed by an XOR with 1. (Integer comparisons always set
429 the result register to 0 or 1.) Floating point comparisons of
430 any kind leave the result in a floating point register, so we
431 need to wrangle an integer register out of things.
433 int_NE_code :: StixTree -> StixTree -> NatM Register
436 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
437 getNewRegNCG IntRep `thenNat` \ tmp ->
439 code = registerCode register tmp
440 src = registerName register tmp
441 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
443 returnNat (Any IntRep code__2)
445 {- ------------------------------------------------------------
446 Comments for int_NE_code also apply to cmpF_code
449 :: (Reg -> Reg -> Reg -> Instr)
451 -> StixTree -> StixTree
454 cmpF_code instr cond x y
455 = trivialFCode pr instr x y `thenNat` \ register ->
456 getNewRegNCG DoubleRep `thenNat` \ tmp ->
457 getNatLabelNCG `thenNat` \ lbl ->
459 code = registerCode register tmp
460 result = registerName register tmp
462 code__2 dst = code . mkSeqInstrs [
463 OR zeroh (RIImm (ImmInt 1)) dst,
464 BF cond result (ImmCLbl lbl),
465 OR zeroh (RIReg zeroh) dst,
468 returnNat (Any IntRep code__2)
470 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
471 ------------------------------------------------------------
473 getRegister (StInd pk mem)
474 = getAmode mem `thenNat` \ amode ->
476 code = amodeCode amode
477 src = amodeAddr amode
478 size = primRepToSize pk
479 code__2 dst = code . mkSeqInstr (LD size dst src)
481 returnNat (Any pk code__2)
483 getRegister (StInt i)
486 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
488 returnNat (Any IntRep code)
491 code dst = mkSeqInstr (LDI Q dst src)
493 returnNat (Any IntRep code)
495 src = ImmInt (fromInteger i)
500 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
502 returnNat (Any PtrRep code)
505 imm__2 = case imm of Just x -> x
507 #endif {- alpha_TARGET_ARCH -}
508 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
511 getRegister (StDouble d)
514 = let code dst = unitOL (GLDZ dst)
515 in returnNat (Any DoubleRep code)
518 = let code dst = unitOL (GLD1 dst)
519 in returnNat (Any DoubleRep code)
522 = getNatLabelNCG `thenNat` \ lbl ->
523 let code dst = toOL [
526 DATA DF [ImmDouble d],
528 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
531 returnNat (Any DoubleRep code)
533 -- Calculate the offset for (i+1) words above the _initial_
534 -- %esp value by first determining the current offset of it.
535 getRegister (StScratchWord i)
537 = getDeltaNat `thenNat` \ current_stack_offset ->
538 let j = i+1 - (current_stack_offset `div` 4)
540 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
542 returnNat (Any PtrRep code)
544 getRegister (StPrim primop [x]) -- unary PrimOps
546 IntNegOp -> trivialUCode (NEGI L) x
547 NotOp -> trivialUCode (NOT L) x
549 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
550 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
552 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
553 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
555 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
556 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
558 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
559 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
561 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
562 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
564 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
565 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
567 OrdOp -> coerceIntCode IntRep x
570 Float2IntOp -> coerceFP2Int x
571 Int2FloatOp -> coerceInt2FP FloatRep x
572 Double2IntOp -> coerceFP2Int x
573 Int2DoubleOp -> coerceInt2FP DoubleRep x
577 fixed_x = if is_float_op -- promote to double
578 then StPrim Float2DoubleOp [x]
581 getRegister (StCall fn cCallConv DoubleRep [x])
585 FloatExpOp -> (True, SLIT("exp"))
586 FloatLogOp -> (True, SLIT("log"))
588 FloatAsinOp -> (True, SLIT("asin"))
589 FloatAcosOp -> (True, SLIT("acos"))
590 FloatAtanOp -> (True, SLIT("atan"))
592 FloatSinhOp -> (True, SLIT("sinh"))
593 FloatCoshOp -> (True, SLIT("cosh"))
594 FloatTanhOp -> (True, SLIT("tanh"))
596 DoubleExpOp -> (False, SLIT("exp"))
597 DoubleLogOp -> (False, SLIT("log"))
599 DoubleAsinOp -> (False, SLIT("asin"))
600 DoubleAcosOp -> (False, SLIT("acos"))
601 DoubleAtanOp -> (False, SLIT("atan"))
603 DoubleSinhOp -> (False, SLIT("sinh"))
604 DoubleCoshOp -> (False, SLIT("cosh"))
605 DoubleTanhOp -> (False, SLIT("tanh"))
608 -> pprPanic "getRegister(x86,unary primop)"
609 (pprStixTree (StPrim primop [x]))
611 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
613 CharGtOp -> condIntReg GTT x y
614 CharGeOp -> condIntReg GE x y
615 CharEqOp -> condIntReg EQQ x y
616 CharNeOp -> condIntReg NE x y
617 CharLtOp -> condIntReg LTT x y
618 CharLeOp -> condIntReg LE x y
620 IntGtOp -> condIntReg GTT x y
621 IntGeOp -> condIntReg GE x y
622 IntEqOp -> condIntReg EQQ x y
623 IntNeOp -> condIntReg NE x y
624 IntLtOp -> condIntReg LTT x y
625 IntLeOp -> condIntReg LE x y
627 WordGtOp -> condIntReg GU x y
628 WordGeOp -> condIntReg GEU x y
629 WordEqOp -> condIntReg EQQ x y
630 WordNeOp -> condIntReg NE x y
631 WordLtOp -> condIntReg LU x y
632 WordLeOp -> condIntReg LEU x y
634 AddrGtOp -> condIntReg GU x y
635 AddrGeOp -> condIntReg GEU x y
636 AddrEqOp -> condIntReg EQQ x y
637 AddrNeOp -> condIntReg NE x y
638 AddrLtOp -> condIntReg LU x y
639 AddrLeOp -> condIntReg LEU x y
641 FloatGtOp -> condFltReg GTT x y
642 FloatGeOp -> condFltReg GE x y
643 FloatEqOp -> condFltReg EQQ x y
644 FloatNeOp -> condFltReg NE x y
645 FloatLtOp -> condFltReg LTT x y
646 FloatLeOp -> condFltReg LE x y
648 DoubleGtOp -> condFltReg GTT x y
649 DoubleGeOp -> condFltReg GE x y
650 DoubleEqOp -> condFltReg EQQ x y
651 DoubleNeOp -> condFltReg NE x y
652 DoubleLtOp -> condFltReg LTT x y
653 DoubleLeOp -> condFltReg LE x y
655 IntAddOp -> add_code L x y
656 IntSubOp -> sub_code L x y
657 IntQuotOp -> quot_code L x y True{-division-}
658 IntRemOp -> quot_code L x y False{-remainder-}
659 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
661 FloatAddOp -> trivialFCode FloatRep GADD x y
662 FloatSubOp -> trivialFCode FloatRep GSUB x y
663 FloatMulOp -> trivialFCode FloatRep GMUL x y
664 FloatDivOp -> trivialFCode FloatRep GDIV x y
666 DoubleAddOp -> trivialFCode DoubleRep GADD x y
667 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
668 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
669 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
671 AndOp -> let op = AND L in trivialCode op (Just op) x y
672 OrOp -> let op = OR L in trivialCode op (Just op) x y
673 XorOp -> let op = XOR L in trivialCode op (Just op) x y
675 {- Shift ops on x86s have constraints on their source, it
676 either has to be Imm, CL or 1
677 => trivialCode's is not restrictive enough (sigh.)
680 SllOp -> shift_code (SHL L) x y {-False-}
681 SrlOp -> shift_code (SHR L) x y {-False-}
682 ISllOp -> shift_code (SHL L) x y {-False-}
683 ISraOp -> shift_code (SAR L) x y {-False-}
684 ISrlOp -> shift_code (SHR L) x y {-False-}
686 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
687 [promote x, promote y])
688 where promote x = StPrim Float2DoubleOp [x]
689 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
692 -> pprPanic "getRegister(x86,dyadic primop)"
693 (pprStixTree (StPrim primop [x, y]))
697 shift_code :: (Imm -> Operand -> Instr)
702 {- Case1: shift length as immediate -}
703 -- Code is the same as the first eq. for trivialCode -- sigh.
704 shift_code instr x y{-amount-}
706 = getRegister x `thenNat` \ regx ->
709 then registerCodeA regx dst `bind` \ code_x ->
711 instr imm__2 (OpReg dst)
712 else registerCodeF regx `bind` \ code_x ->
713 registerNameF regx `bind` \ r_x ->
715 MOV L (OpReg r_x) (OpReg dst) `snocOL`
716 instr imm__2 (OpReg dst)
718 returnNat (Any IntRep mkcode)
721 imm__2 = case imm of Just x -> x
723 {- Case2: shift length is complex (non-immediate) -}
724 -- Since ECX is always used as a spill temporary, we can't
725 -- use it here to do non-immediate shifts. No big deal --
726 -- they are only very rare, and we can use an equivalent
727 -- test-and-jump sequence which doesn't use ECX.
728 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
729 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
730 shift_code instr x y{-amount-}
731 = getRegister x `thenNat` \ register1 ->
732 getRegister y `thenNat` \ register2 ->
733 getNatLabelNCG `thenNat` \ lbl_test3 ->
734 getNatLabelNCG `thenNat` \ lbl_test2 ->
735 getNatLabelNCG `thenNat` \ lbl_test1 ->
736 getNatLabelNCG `thenNat` \ lbl_test0 ->
737 getNatLabelNCG `thenNat` \ lbl_after ->
738 getNewRegNCG IntRep `thenNat` \ tmp ->
740 = let src_val = registerName register1 dst
741 code_val = registerCode register1 dst
742 src_amt = registerName register2 tmp
743 code_amt = registerCode register2 tmp
748 MOV L (OpReg src_amt) r_tmp `appOL`
750 MOV L (OpReg src_val) r_dst `appOL`
752 COMMENT (_PK_ "begin shift sequence"),
753 MOV L (OpReg src_val) r_dst,
754 MOV L (OpReg src_amt) r_tmp,
756 BT L (ImmInt 4) r_tmp,
758 instr (ImmInt 16) r_dst,
761 BT L (ImmInt 3) r_tmp,
763 instr (ImmInt 8) r_dst,
766 BT L (ImmInt 2) r_tmp,
768 instr (ImmInt 4) r_dst,
771 BT L (ImmInt 1) r_tmp,
773 instr (ImmInt 2) r_dst,
776 BT L (ImmInt 0) r_tmp,
778 instr (ImmInt 1) r_dst,
781 COMMENT (_PK_ "end shift sequence")
784 returnNat (Any IntRep code__2)
787 add_code :: Size -> StixTree -> StixTree -> NatM Register
789 add_code sz x (StInt y)
790 = getRegister x `thenNat` \ register ->
791 getNewRegNCG IntRep `thenNat` \ tmp ->
793 code = registerCode register tmp
794 src1 = registerName register tmp
795 src2 = ImmInt (fromInteger y)
798 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
801 returnNat (Any IntRep code__2)
803 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
806 sub_code :: Size -> StixTree -> StixTree -> NatM Register
808 sub_code sz x (StInt y)
809 = getRegister x `thenNat` \ register ->
810 getNewRegNCG IntRep `thenNat` \ tmp ->
812 code = registerCode register tmp
813 src1 = registerName register tmp
814 src2 = ImmInt (-(fromInteger y))
817 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
820 returnNat (Any IntRep code__2)
822 sub_code sz x y = trivialCode (SUB sz) Nothing x y
827 -> StixTree -> StixTree
828 -> Bool -- True => division, False => remainder operation
831 -- x must go into eax, edx must be a sign-extension of eax, and y
832 -- should go in some other register (or memory), so that we get
833 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
834 -- to put y on the C stack, since that avoids tying up yet another
835 -- precious register.
837 quot_code sz x y is_division
838 = getRegister x `thenNat` \ register1 ->
839 getRegister y `thenNat` \ register2 ->
840 getNewRegNCG IntRep `thenNat` \ tmp ->
841 getDeltaNat `thenNat` \ delta ->
843 code1 = registerCode register1 tmp
844 src1 = registerName register1 tmp
845 code2 = registerCode register2 tmp
846 src2 = registerName register2 tmp
847 code__2 = code2 `snocOL` -- src2 := y
848 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
849 DELTA (delta-4) `appOL`
850 code1 `snocOL` -- src1 := x
851 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
853 IDIV sz (OpAddr (spRel 0)) `snocOL`
854 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
857 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
858 -----------------------
860 getRegister (StInd pk mem)
861 = getAmode mem `thenNat` \ amode ->
863 code = amodeCode amode
864 src = amodeAddr amode
865 size = primRepToSize pk
866 code__2 dst = code `snocOL`
867 if pk == DoubleRep || pk == FloatRep
868 then GLD size src dst
870 L -> MOV L (OpAddr src) (OpReg dst)
871 B -> MOVZxL B (OpAddr src) (OpReg dst)
873 returnNat (Any pk code__2)
875 getRegister (StInt i)
877 src = ImmInt (fromInteger i)
880 = unitOL (XOR L (OpReg dst) (OpReg dst))
882 = unitOL (MOV L (OpImm src) (OpReg dst))
884 returnNat (Any IntRep code)
888 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
890 returnNat (Any PtrRep code)
892 = pprPanic "getRegister(x86)" (pprStixTree leaf)
895 imm__2 = case imm of Just x -> x
897 #endif {- i386_TARGET_ARCH -}
898 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
899 #if sparc_TARGET_ARCH
901 getRegister (StDouble d)
902 = getNatLabelNCG `thenNat` \ lbl ->
903 getNewRegNCG PtrRep `thenNat` \ tmp ->
904 let code dst = toOL [
907 DATA DF [ImmDouble d],
909 SETHI (HI (ImmCLbl lbl)) tmp,
910 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
912 returnNat (Any DoubleRep code)
914 getRegister (StPrim primop [x]) -- unary PrimOps
916 IntNegOp -> trivialUCode (SUB False False g0) x
917 NotOp -> trivialUCode (XNOR False g0) x
919 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
921 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
923 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
924 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
926 OrdOp -> coerceIntCode IntRep x
929 Float2IntOp -> coerceFP2Int x
930 Int2FloatOp -> coerceInt2FP FloatRep x
931 Double2IntOp -> coerceFP2Int x
932 Int2DoubleOp -> coerceInt2FP DoubleRep x
936 fixed_x = if is_float_op -- promote to double
937 then StPrim Float2DoubleOp [x]
940 getRegister (StCall fn cCallConv DoubleRep [x])
944 FloatExpOp -> (True, SLIT("exp"))
945 FloatLogOp -> (True, SLIT("log"))
946 FloatSqrtOp -> (True, SLIT("sqrt"))
948 FloatSinOp -> (True, SLIT("sin"))
949 FloatCosOp -> (True, SLIT("cos"))
950 FloatTanOp -> (True, SLIT("tan"))
952 FloatAsinOp -> (True, SLIT("asin"))
953 FloatAcosOp -> (True, SLIT("acos"))
954 FloatAtanOp -> (True, SLIT("atan"))
956 FloatSinhOp -> (True, SLIT("sinh"))
957 FloatCoshOp -> (True, SLIT("cosh"))
958 FloatTanhOp -> (True, SLIT("tanh"))
960 DoubleExpOp -> (False, SLIT("exp"))
961 DoubleLogOp -> (False, SLIT("log"))
962 DoubleSqrtOp -> (True, SLIT("sqrt"))
964 DoubleSinOp -> (False, SLIT("sin"))
965 DoubleCosOp -> (False, SLIT("cos"))
966 DoubleTanOp -> (False, SLIT("tan"))
968 DoubleAsinOp -> (False, SLIT("asin"))
969 DoubleAcosOp -> (False, SLIT("acos"))
970 DoubleAtanOp -> (False, SLIT("atan"))
972 DoubleSinhOp -> (False, SLIT("sinh"))
973 DoubleCoshOp -> (False, SLIT("cosh"))
974 DoubleTanhOp -> (False, SLIT("tanh"))
975 _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
977 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
979 CharGtOp -> condIntReg GTT x y
980 CharGeOp -> condIntReg GE x y
981 CharEqOp -> condIntReg EQQ x y
982 CharNeOp -> condIntReg NE x y
983 CharLtOp -> condIntReg LTT x y
984 CharLeOp -> condIntReg LE x y
986 IntGtOp -> condIntReg GTT x y
987 IntGeOp -> condIntReg GE x y
988 IntEqOp -> condIntReg EQQ x y
989 IntNeOp -> condIntReg NE x y
990 IntLtOp -> condIntReg LTT x y
991 IntLeOp -> condIntReg LE x y
993 WordGtOp -> condIntReg GU x y
994 WordGeOp -> condIntReg GEU x y
995 WordEqOp -> condIntReg EQQ x y
996 WordNeOp -> condIntReg NE x y
997 WordLtOp -> condIntReg LU x y
998 WordLeOp -> condIntReg LEU x y
1000 AddrGtOp -> condIntReg GU x y
1001 AddrGeOp -> condIntReg GEU x y
1002 AddrEqOp -> condIntReg EQQ x y
1003 AddrNeOp -> condIntReg NE x y
1004 AddrLtOp -> condIntReg LU x y
1005 AddrLeOp -> condIntReg LEU x y
1007 FloatGtOp -> condFltReg GTT x y
1008 FloatGeOp -> condFltReg GE x y
1009 FloatEqOp -> condFltReg EQQ x y
1010 FloatNeOp -> condFltReg NE x y
1011 FloatLtOp -> condFltReg LTT x y
1012 FloatLeOp -> condFltReg LE x y
1014 DoubleGtOp -> condFltReg GTT x y
1015 DoubleGeOp -> condFltReg GE x y
1016 DoubleEqOp -> condFltReg EQQ x y
1017 DoubleNeOp -> condFltReg NE x y
1018 DoubleLtOp -> condFltReg LTT x y
1019 DoubleLeOp -> condFltReg LE x y
1021 IntAddOp -> trivialCode (ADD False False) x y
1022 IntSubOp -> trivialCode (SUB False False) x y
1024 -- ToDo: teach about V8+ SPARC mul/div instructions
1025 IntMulOp -> imul_div SLIT(".umul") x y
1026 IntQuotOp -> imul_div SLIT(".div") x y
1027 IntRemOp -> imul_div SLIT(".rem") x y
1029 FloatAddOp -> trivialFCode FloatRep FADD x y
1030 FloatSubOp -> trivialFCode FloatRep FSUB x y
1031 FloatMulOp -> trivialFCode FloatRep FMUL x y
1032 FloatDivOp -> trivialFCode FloatRep FDIV x y
1034 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1035 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1036 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1037 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1039 AndOp -> trivialCode (AND False) x y
1040 OrOp -> trivialCode (OR False) x y
1041 XorOp -> trivialCode (XOR False) x y
1042 SllOp -> trivialCode SLL x y
1043 SrlOp -> trivialCode SRL x y
1045 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1046 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1047 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1049 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1050 where promote x = StPrim Float2DoubleOp [x]
1051 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1052 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1054 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1056 getRegister (StInd pk mem)
1057 = getAmode mem `thenNat` \ amode ->
1059 code = amodeCode amode
1060 src = amodeAddr amode
1061 size = primRepToSize pk
1062 code__2 dst = code `snocOL` LD size src dst
1064 returnNat (Any pk code__2)
1066 getRegister (StInt i)
1069 src = ImmInt (fromInteger i)
1070 code dst = unitOL (OR False g0 (RIImm src) dst)
1072 returnNat (Any IntRep code)
1078 SETHI (HI imm__2) dst,
1079 OR False dst (RIImm (LO imm__2)) dst]
1081 returnNat (Any PtrRep code)
1084 imm__2 = case imm of Just x -> x
1086 #endif {- sparc_TARGET_ARCH -}
1089 %************************************************************************
1091 \subsection{The @Amode@ type}
1093 %************************************************************************
1095 @Amode@s: Memory addressing modes passed up the tree.
1097 data Amode = Amode MachRegsAddr InstrBlock
1099 amodeAddr (Amode addr _) = addr
1100 amodeCode (Amode _ code) = code
1103 Now, given a tree (the argument to an StInd) that references memory,
1104 produce a suitable addressing mode.
1106 A Rule of the Game (tm) for Amodes: use of the addr bit must
1107 immediately follow use of the code part, since the code part puts
1108 values in registers which the addr then refers to. So you can't put
1109 anything in between, lest it overwrite some of those registers. If
1110 you need to do some other computation between the code part and use of
1111 the addr bit, first store the effective address from the amode in a
1112 temporary, then do the other computation, and then use the temporary:
1116 ... other computation ...
1120 getAmode :: StixTree -> NatM Amode
1122 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1124 #if alpha_TARGET_ARCH
1126 getAmode (StPrim IntSubOp [x, StInt i])
1127 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1128 getRegister x `thenNat` \ register ->
1130 code = registerCode register tmp
1131 reg = registerName register tmp
1132 off = ImmInt (-(fromInteger i))
1134 returnNat (Amode (AddrRegImm reg off) code)
1136 getAmode (StPrim IntAddOp [x, StInt i])
1137 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1138 getRegister x `thenNat` \ register ->
1140 code = registerCode register tmp
1141 reg = registerName register tmp
1142 off = ImmInt (fromInteger i)
1144 returnNat (Amode (AddrRegImm reg off) code)
1148 = returnNat (Amode (AddrImm imm__2) id)
1151 imm__2 = case imm of Just x -> x
1154 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1155 getRegister other `thenNat` \ register ->
1157 code = registerCode register tmp
1158 reg = registerName register tmp
1160 returnNat (Amode (AddrReg reg) code)
1162 #endif {- alpha_TARGET_ARCH -}
1163 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1164 #if i386_TARGET_ARCH
1166 getAmode (StPrim IntSubOp [x, StInt i])
1167 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1168 getRegister x `thenNat` \ register ->
1170 code = registerCode register tmp
1171 reg = registerName register tmp
1172 off = ImmInt (-(fromInteger i))
1174 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1176 getAmode (StPrim IntAddOp [x, StInt i])
1178 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1181 imm__2 = case imm of Just x -> x
1183 getAmode (StPrim IntAddOp [x, StInt i])
1184 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1185 getRegister x `thenNat` \ register ->
1187 code = registerCode register tmp
1188 reg = registerName register tmp
1189 off = ImmInt (fromInteger i)
1191 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1193 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1194 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1195 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1196 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1197 getRegister x `thenNat` \ register1 ->
1198 getRegister y `thenNat` \ register2 ->
1200 code1 = registerCode register1 tmp1
1201 reg1 = registerName register1 tmp1
1202 code2 = registerCode register2 tmp2
1203 reg2 = registerName register2 tmp2
1204 code__2 = code1 `appOL` code2
1205 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1207 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1212 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1215 imm__2 = case imm of Just x -> x
1218 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1219 getRegister other `thenNat` \ register ->
1221 code = registerCode register tmp
1222 reg = registerName register tmp
1224 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1226 #endif {- i386_TARGET_ARCH -}
1227 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1228 #if sparc_TARGET_ARCH
1230 getAmode (StPrim IntSubOp [x, StInt i])
1232 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1233 getRegister x `thenNat` \ register ->
1235 code = registerCode register tmp
1236 reg = registerName register tmp
1237 off = ImmInt (-(fromInteger i))
1239 returnNat (Amode (AddrRegImm reg off) code)
1242 getAmode (StPrim IntAddOp [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)
1253 getAmode (StPrim IntAddOp [x, y])
1254 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1255 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1256 getRegister x `thenNat` \ register1 ->
1257 getRegister y `thenNat` \ register2 ->
1259 code1 = registerCode register1 tmp1
1260 reg1 = registerName register1 tmp1
1261 code2 = registerCode register2 tmp2
1262 reg2 = registerName register2 tmp2
1263 code__2 = code1 `appOL` code2
1265 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1269 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1271 code = unitOL (SETHI (HI imm__2) tmp)
1273 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1276 imm__2 = case imm of Just x -> x
1279 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1280 getRegister other `thenNat` \ register ->
1282 code = registerCode register tmp
1283 reg = registerName register tmp
1286 returnNat (Amode (AddrRegImm reg off) code)
1288 #endif {- sparc_TARGET_ARCH -}
1291 %************************************************************************
1293 \subsection{The @CondCode@ type}
1295 %************************************************************************
1297 Condition codes passed up the tree.
1299 data CondCode = CondCode Bool Cond InstrBlock
1301 condName (CondCode _ cond _) = cond
1302 condFloat (CondCode is_float _ _) = is_float
1303 condCode (CondCode _ _ code) = code
1306 Set up a condition code for a conditional branch.
1309 getCondCode :: StixTree -> NatM CondCode
1311 #if alpha_TARGET_ARCH
1312 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1313 #endif {- alpha_TARGET_ARCH -}
1314 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1316 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1317 -- yes, they really do seem to want exactly the same!
1319 getCondCode (StPrim primop [x, y])
1321 CharGtOp -> condIntCode GTT x y
1322 CharGeOp -> condIntCode GE x y
1323 CharEqOp -> condIntCode EQQ x y
1324 CharNeOp -> condIntCode NE x y
1325 CharLtOp -> condIntCode LTT x y
1326 CharLeOp -> condIntCode LE x y
1328 IntGtOp -> condIntCode GTT x y
1329 IntGeOp -> condIntCode GE x y
1330 IntEqOp -> condIntCode EQQ x y
1331 IntNeOp -> condIntCode NE x y
1332 IntLtOp -> condIntCode LTT x y
1333 IntLeOp -> condIntCode LE x y
1335 WordGtOp -> condIntCode GU x y
1336 WordGeOp -> condIntCode GEU x y
1337 WordEqOp -> condIntCode EQQ x y
1338 WordNeOp -> condIntCode NE x y
1339 WordLtOp -> condIntCode LU x y
1340 WordLeOp -> condIntCode LEU x y
1342 AddrGtOp -> condIntCode GU x y
1343 AddrGeOp -> condIntCode GEU x y
1344 AddrEqOp -> condIntCode EQQ x y
1345 AddrNeOp -> condIntCode NE x y
1346 AddrLtOp -> condIntCode LU x y
1347 AddrLeOp -> condIntCode LEU x y
1349 FloatGtOp -> condFltCode GTT x y
1350 FloatGeOp -> condFltCode GE x y
1351 FloatEqOp -> condFltCode EQQ x y
1352 FloatNeOp -> condFltCode NE x y
1353 FloatLtOp -> condFltCode LTT x y
1354 FloatLeOp -> condFltCode LE x y
1356 DoubleGtOp -> condFltCode GTT x y
1357 DoubleGeOp -> condFltCode GE x y
1358 DoubleEqOp -> condFltCode EQQ x y
1359 DoubleNeOp -> condFltCode NE x y
1360 DoubleLtOp -> condFltCode LTT x y
1361 DoubleLeOp -> condFltCode LE x y
1363 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1368 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1369 passed back up the tree.
1372 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1374 #if alpha_TARGET_ARCH
1375 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1376 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1377 #endif {- alpha_TARGET_ARCH -}
1379 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1380 #if i386_TARGET_ARCH
1382 -- memory vs immediate
1383 condIntCode cond (StInd pk x) y
1385 = getAmode x `thenNat` \ amode ->
1387 code1 = amodeCode amode
1388 x__2 = amodeAddr amode
1389 sz = primRepToSize pk
1390 code__2 = code1 `snocOL`
1391 CMP sz (OpImm imm__2) (OpAddr x__2)
1393 returnNat (CondCode False cond code__2)
1396 imm__2 = case imm of Just x -> x
1399 condIntCode cond x (StInt 0)
1400 = getRegister x `thenNat` \ register1 ->
1401 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1403 code1 = registerCode register1 tmp1
1404 src1 = registerName register1 tmp1
1405 code__2 = code1 `snocOL`
1406 TEST L (OpReg src1) (OpReg src1)
1408 returnNat (CondCode False cond code__2)
1410 -- anything vs immediate
1411 condIntCode cond x y
1413 = getRegister x `thenNat` \ register1 ->
1414 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1416 code1 = registerCode register1 tmp1
1417 src1 = registerName register1 tmp1
1418 code__2 = code1 `snocOL`
1419 CMP L (OpImm imm__2) (OpReg src1)
1421 returnNat (CondCode False cond code__2)
1424 imm__2 = case imm of Just x -> x
1426 -- memory vs anything
1427 condIntCode cond (StInd pk x) y
1428 = getAmode x `thenNat` \ amode_x ->
1429 getRegister y `thenNat` \ reg_y ->
1430 getNewRegNCG IntRep `thenNat` \ tmp ->
1432 c_x = amodeCode amode_x
1433 am_x = amodeAddr amode_x
1434 c_y = registerCode reg_y tmp
1435 r_y = registerName reg_y tmp
1436 sz = primRepToSize pk
1438 -- optimisation: if there's no code for x, just an amode,
1439 -- use whatever reg y winds up in. Assumes that c_y doesn't
1440 -- clobber any regs in the amode am_x, which I'm not sure is
1441 -- justified. The otherwise clause makes the same assumption.
1442 code__2 | isNilOL c_x
1444 CMP sz (OpReg r_y) (OpAddr am_x)
1448 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1450 CMP sz (OpReg tmp) (OpAddr am_x)
1452 returnNat (CondCode False cond code__2)
1454 -- anything vs memory
1456 condIntCode cond y (StInd pk x)
1457 = getAmode x `thenNat` \ amode_x ->
1458 getRegister y `thenNat` \ reg_y ->
1459 getNewRegNCG IntRep `thenNat` \ tmp ->
1461 c_x = amodeCode amode_x
1462 am_x = amodeAddr amode_x
1463 c_y = registerCode reg_y tmp
1464 r_y = registerName reg_y tmp
1465 sz = primRepToSize pk
1466 -- same optimisation and nagging doubts as previous clause
1467 code__2 | isNilOL c_x
1469 CMP sz (OpAddr am_x) (OpReg r_y)
1473 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1475 CMP sz (OpAddr am_x) (OpReg tmp)
1477 returnNat (CondCode False cond code__2)
1479 -- anything vs anything
1480 condIntCode cond x y
1481 = getRegister x `thenNat` \ register1 ->
1482 getRegister y `thenNat` \ register2 ->
1483 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1484 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1486 code1 = registerCode register1 tmp1
1487 src1 = registerName register1 tmp1
1488 code2 = registerCode register2 tmp2
1489 src2 = registerName register2 tmp2
1490 code__2 = code1 `snocOL`
1491 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1493 CMP L (OpReg src2) (OpReg tmp1)
1495 returnNat (CondCode False cond code__2)
1498 condFltCode cond x y
1499 = getRegister x `thenNat` \ register1 ->
1500 getRegister y `thenNat` \ register2 ->
1501 getNewRegNCG (registerRep register1)
1503 getNewRegNCG (registerRep register2)
1505 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1507 pk1 = registerRep register1
1508 code1 = registerCode register1 tmp1
1509 src1 = registerName register1 tmp1
1511 pk2 = registerRep register2
1512 code2 = registerCode register2 tmp2
1513 src2 = registerName register2 tmp2
1515 code__2 | isAny register1
1516 = code1 `appOL` -- result in tmp1
1518 GCMP (primRepToSize pk1) tmp1 src2
1522 GMOV src1 tmp1 `appOL`
1524 GCMP (primRepToSize pk1) tmp1 src2
1526 {- On the 486, the flags set by FP compare are the unsigned ones!
1527 (This looks like a HACK to me. WDP 96/03)
1529 fix_FP_cond :: Cond -> Cond
1531 fix_FP_cond GE = GEU
1532 fix_FP_cond GTT = GU
1533 fix_FP_cond LTT = LU
1534 fix_FP_cond LE = LEU
1535 fix_FP_cond any = any
1537 returnNat (CondCode True (fix_FP_cond cond) code__2)
1541 #endif {- i386_TARGET_ARCH -}
1542 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1543 #if sparc_TARGET_ARCH
1545 condIntCode cond x (StInt y)
1547 = getRegister x `thenNat` \ register ->
1548 getNewRegNCG IntRep `thenNat` \ tmp ->
1550 code = registerCode register tmp
1551 src1 = registerName register tmp
1552 src2 = ImmInt (fromInteger y)
1553 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1555 returnNat (CondCode False cond code__2)
1557 condIntCode cond x y
1558 = getRegister x `thenNat` \ register1 ->
1559 getRegister y `thenNat` \ register2 ->
1560 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1561 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1563 code1 = registerCode register1 tmp1
1564 src1 = registerName register1 tmp1
1565 code2 = registerCode register2 tmp2
1566 src2 = registerName register2 tmp2
1567 code__2 = code1 `appOL` code2 `snocOL`
1568 SUB False True src1 (RIReg src2) g0
1570 returnNat (CondCode False cond code__2)
1573 condFltCode cond x y
1574 = getRegister x `thenNat` \ register1 ->
1575 getRegister y `thenNat` \ register2 ->
1576 getNewRegNCG (registerRep register1)
1578 getNewRegNCG (registerRep register2)
1580 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1582 promote x = FxTOy F DF x tmp
1584 pk1 = registerRep register1
1585 code1 = registerCode register1 tmp1
1586 src1 = registerName register1 tmp1
1588 pk2 = registerRep register2
1589 code2 = registerCode register2 tmp2
1590 src2 = registerName register2 tmp2
1594 code1 `appOL` code2 `snocOL`
1595 FCMP True (primRepToSize pk1) src1 src2
1596 else if pk1 == FloatRep then
1597 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1598 FCMP True DF tmp src2
1600 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1601 FCMP True DF src1 tmp
1603 returnNat (CondCode True cond code__2)
1605 #endif {- sparc_TARGET_ARCH -}
1608 %************************************************************************
1610 \subsection{Generating assignments}
1612 %************************************************************************
1614 Assignments are really at the heart of the whole code generation
1615 business. Almost all top-level nodes of any real importance are
1616 assignments, which correspond to loads, stores, or register transfers.
1617 If we're really lucky, some of the register transfers will go away,
1618 because we can use the destination register to complete the code
1619 generation for the right hand side. This only fails when the right
1620 hand side is forced into a fixed register (e.g. the result of a call).
1623 assignIntCode, assignFltCode
1624 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1626 #if alpha_TARGET_ARCH
1628 assignIntCode pk (StInd _ dst) src
1629 = getNewRegNCG IntRep `thenNat` \ tmp ->
1630 getAmode dst `thenNat` \ amode ->
1631 getRegister src `thenNat` \ register ->
1633 code1 = amodeCode amode []
1634 dst__2 = amodeAddr amode
1635 code2 = registerCode register tmp []
1636 src__2 = registerName register tmp
1637 sz = primRepToSize pk
1638 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1642 assignIntCode pk dst src
1643 = getRegister dst `thenNat` \ register1 ->
1644 getRegister src `thenNat` \ register2 ->
1646 dst__2 = registerName register1 zeroh
1647 code = registerCode register2 dst__2
1648 src__2 = registerName register2 dst__2
1649 code__2 = if isFixed register2
1650 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1655 #endif {- alpha_TARGET_ARCH -}
1656 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1657 #if i386_TARGET_ARCH
1659 -- Destination of an assignment can only be reg or mem.
1660 -- This is the mem case.
1661 assignIntCode pk (StInd _ dst) src
1662 = getAmode dst `thenNat` \ amode ->
1663 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1664 getNewRegNCG PtrRep `thenNat` \ tmp ->
1666 -- In general, if the address computation for dst may require
1667 -- some insns preceding the addressing mode itself. So there's
1668 -- no guarantee that the code for dst and the code for src won't
1669 -- write the same register. This means either the address or
1670 -- the value needs to be copied into a temporary. We detect the
1671 -- common case where the amode has no code, and elide the copy.
1672 codea = amodeCode amode
1673 dst__a = amodeAddr amode
1675 code | isNilOL codea
1677 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1681 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1683 MOV (primRepToSize pk) opsrc
1684 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1690 -> NatM (InstrBlock,Operand) -- code, operator
1694 = returnNat (nilOL, OpImm imm_op)
1697 imm_op = case imm of Just x -> x
1700 = getRegister op `thenNat` \ register ->
1701 getNewRegNCG (registerRep register)
1703 let code = registerCode register tmp
1704 reg = registerName register tmp
1706 returnNat (code, OpReg reg)
1708 -- Assign; dst is a reg, rhs is mem
1709 assignIntCode pk dst (StInd pks src)
1710 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1711 getAmode src `thenNat` \ amode ->
1712 getRegister dst `thenNat` \ reg_dst ->
1714 c_addr = amodeCode amode
1715 am_addr = amodeAddr amode
1717 c_dst = registerCode reg_dst tmp -- should be empty
1718 r_dst = registerName reg_dst tmp
1719 szs = primRepToSize pks
1720 opc = case szs of L -> MOV L ; B -> MOVZxL B
1722 code | isNilOL c_dst
1724 opc (OpAddr am_addr) (OpReg r_dst)
1726 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1730 -- dst is a reg, but src could be anything
1731 assignIntCode pk dst src
1732 = getRegister dst `thenNat` \ registerd ->
1733 getRegister src `thenNat` \ registers ->
1734 getNewRegNCG IntRep `thenNat` \ tmp ->
1736 r_dst = registerName registerd tmp
1737 c_dst = registerCode registerd tmp -- should be empty
1738 r_src = registerName registers r_dst
1739 c_src = registerCode registers r_dst
1741 code | isNilOL c_dst
1743 MOV L (OpReg r_src) (OpReg r_dst)
1745 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1749 #endif {- i386_TARGET_ARCH -}
1750 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1751 #if sparc_TARGET_ARCH
1753 assignIntCode pk (StInd _ dst) src
1754 = getNewRegNCG IntRep `thenNat` \ tmp ->
1755 getAmode dst `thenNat` \ amode ->
1756 getRegister src `thenNat` \ register ->
1758 code1 = amodeCode amode
1759 dst__2 = amodeAddr amode
1760 code2 = registerCode register tmp
1761 src__2 = registerName register tmp
1762 sz = primRepToSize pk
1763 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1767 assignIntCode pk dst src
1768 = getRegister dst `thenNat` \ register1 ->
1769 getRegister src `thenNat` \ register2 ->
1771 dst__2 = registerName register1 g0
1772 code = registerCode register2 dst__2
1773 src__2 = registerName register2 dst__2
1774 code__2 = if isFixed register2
1775 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1780 #endif {- sparc_TARGET_ARCH -}
1783 % --------------------------------
1784 Floating-point assignments:
1785 % --------------------------------
1787 #if alpha_TARGET_ARCH
1789 assignFltCode pk (StInd _ dst) src
1790 = getNewRegNCG pk `thenNat` \ tmp ->
1791 getAmode dst `thenNat` \ amode ->
1792 getRegister src `thenNat` \ register ->
1794 code1 = amodeCode amode []
1795 dst__2 = amodeAddr amode
1796 code2 = registerCode register tmp []
1797 src__2 = registerName register tmp
1798 sz = primRepToSize pk
1799 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1803 assignFltCode pk dst src
1804 = getRegister dst `thenNat` \ register1 ->
1805 getRegister src `thenNat` \ register2 ->
1807 dst__2 = registerName register1 zeroh
1808 code = registerCode register2 dst__2
1809 src__2 = registerName register2 dst__2
1810 code__2 = if isFixed register2
1811 then code . mkSeqInstr (FMOV src__2 dst__2)
1816 #endif {- alpha_TARGET_ARCH -}
1817 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1818 #if i386_TARGET_ARCH
1821 assignFltCode pk (StInd pk_dst addr) src
1823 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1825 = getRegister src `thenNat` \ reg_src ->
1826 getRegister addr `thenNat` \ reg_addr ->
1827 getNewRegNCG pk `thenNat` \ tmp_src ->
1828 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1829 let r_src = registerName reg_src tmp_src
1830 c_src = registerCode reg_src tmp_src
1831 r_addr = registerName reg_addr tmp_addr
1832 c_addr = registerCode reg_addr tmp_addr
1833 sz = primRepToSize pk
1835 code = c_src `appOL`
1836 -- no need to preserve r_src across the addr computation,
1837 -- since r_src must be a float reg
1838 -- whilst r_addr is an int reg
1841 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1845 -- dst must be a (FP) register
1846 assignFltCode pk dst src
1847 = getRegister dst `thenNat` \ reg_dst ->
1848 getRegister src `thenNat` \ reg_src ->
1849 getNewRegNCG pk `thenNat` \ tmp ->
1851 r_dst = registerName reg_dst tmp
1852 c_dst = registerCode reg_dst tmp -- should be empty
1854 r_src = registerName reg_src r_dst
1855 c_src = registerCode reg_src r_dst
1857 code | isNilOL c_dst
1858 = if isFixed reg_src
1859 then c_src `snocOL` GMOV r_src r_dst
1862 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1868 #endif {- i386_TARGET_ARCH -}
1869 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1870 #if sparc_TARGET_ARCH
1872 assignFltCode pk (StInd _ dst) src
1873 = getNewRegNCG pk `thenNat` \ tmp1 ->
1874 getAmode dst `thenNat` \ amode ->
1875 getRegister src `thenNat` \ register ->
1877 sz = primRepToSize pk
1878 dst__2 = amodeAddr amode
1880 code1 = amodeCode amode
1881 code2 = registerCode register tmp1
1883 src__2 = registerName register tmp1
1884 pk__2 = registerRep register
1885 sz__2 = primRepToSize pk__2
1887 code__2 = code1 `appOL` code2 `appOL`
1889 then unitOL (ST sz src__2 dst__2)
1890 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1894 assignFltCode pk dst src
1895 = getRegister dst `thenNat` \ register1 ->
1896 getRegister src `thenNat` \ register2 ->
1898 pk__2 = registerRep register2
1899 sz__2 = primRepToSize pk__2
1901 getNewRegNCG pk__2 `thenNat` \ tmp ->
1903 sz = primRepToSize pk
1904 dst__2 = registerName register1 g0 -- must be Fixed
1907 reg__2 = if pk /= pk__2 then tmp else dst__2
1909 code = registerCode register2 reg__2
1911 src__2 = registerName register2 reg__2
1915 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1916 else if isFixed register2 then
1917 code `snocOL` FMOV sz src__2 dst__2
1923 #endif {- sparc_TARGET_ARCH -}
1926 %************************************************************************
1928 \subsection{Generating an unconditional branch}
1930 %************************************************************************
1932 We accept two types of targets: an immediate CLabel or a tree that
1933 gets evaluated into a register. Any CLabels which are AsmTemporaries
1934 are assumed to be in the local block of code, close enough for a
1935 branch instruction. Other CLabels are assumed to be far away.
1937 (If applicable) Do not fill the delay slots here; you will confuse the
1941 genJump :: StixTree{-the branch target-} -> NatM InstrBlock
1943 #if alpha_TARGET_ARCH
1945 genJump (StCLbl lbl)
1946 | isAsmTemp lbl = returnInstr (BR target)
1947 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1949 target = ImmCLbl lbl
1952 = getRegister tree `thenNat` \ register ->
1953 getNewRegNCG PtrRep `thenNat` \ tmp ->
1955 dst = registerName register pv
1956 code = registerCode register pv
1957 target = registerName register pv
1959 if isFixed register then
1960 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1962 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1964 #endif {- alpha_TARGET_ARCH -}
1965 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1966 #if i386_TARGET_ARCH
1968 genJump (StInd pk mem)
1969 = getAmode mem `thenNat` \ amode ->
1971 code = amodeCode amode
1972 target = amodeAddr amode
1974 returnNat (code `snocOL` JMP (OpAddr target))
1978 = returnNat (unitOL (JMP (OpImm target)))
1981 = getRegister tree `thenNat` \ register ->
1982 getNewRegNCG PtrRep `thenNat` \ tmp ->
1984 code = registerCode register tmp
1985 target = registerName register tmp
1987 returnNat (code `snocOL` JMP (OpReg target))
1990 target = case imm of Just x -> x
1992 #endif {- i386_TARGET_ARCH -}
1993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1994 #if sparc_TARGET_ARCH
1996 genJump (StCLbl lbl)
1997 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
1998 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2000 target = ImmCLbl lbl
2003 = getRegister tree `thenNat` \ register ->
2004 getNewRegNCG PtrRep `thenNat` \ tmp ->
2006 code = registerCode register tmp
2007 target = registerName register tmp
2009 returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
2011 #endif {- sparc_TARGET_ARCH -}
2014 %************************************************************************
2016 \subsection{Conditional jumps}
2018 %************************************************************************
2020 Conditional jumps are always to local labels, so we can use branch
2021 instructions. We peek at the arguments to decide what kind of
2024 ALPHA: For comparisons with 0, we're laughing, because we can just do
2025 the desired conditional branch.
2027 I386: First, we have to ensure that the condition
2028 codes are set according to the supplied comparison operation.
2030 SPARC: First, we have to ensure that the condition codes are set
2031 according to the supplied comparison operation. We generate slightly
2032 different code for floating point comparisons, because a floating
2033 point operation cannot directly precede a @BF@. We assume the worst
2034 and fill that slot with a @NOP@.
2036 SPARC: Do not fill the delay slots here; you will confuse the register
2041 :: CLabel -- the branch target
2042 -> StixTree -- the condition on which to branch
2045 #if alpha_TARGET_ARCH
2047 genCondJump lbl (StPrim op [x, StInt 0])
2048 = getRegister x `thenNat` \ register ->
2049 getNewRegNCG (registerRep register)
2052 code = registerCode register tmp
2053 value = registerName register tmp
2054 pk = registerRep register
2055 target = ImmCLbl lbl
2057 returnSeq code [BI (cmpOp op) value target]
2059 cmpOp CharGtOp = GTT
2061 cmpOp CharEqOp = EQQ
2063 cmpOp CharLtOp = LTT
2072 cmpOp WordGeOp = ALWAYS
2073 cmpOp WordEqOp = EQQ
2075 cmpOp WordLtOp = NEVER
2076 cmpOp WordLeOp = EQQ
2078 cmpOp AddrGeOp = ALWAYS
2079 cmpOp AddrEqOp = EQQ
2081 cmpOp AddrLtOp = NEVER
2082 cmpOp AddrLeOp = EQQ
2084 genCondJump lbl (StPrim op [x, StDouble 0.0])
2085 = getRegister x `thenNat` \ register ->
2086 getNewRegNCG (registerRep register)
2089 code = registerCode register tmp
2090 value = registerName register tmp
2091 pk = registerRep register
2092 target = ImmCLbl lbl
2094 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2096 cmpOp FloatGtOp = GTT
2097 cmpOp FloatGeOp = GE
2098 cmpOp FloatEqOp = EQQ
2099 cmpOp FloatNeOp = NE
2100 cmpOp FloatLtOp = LTT
2101 cmpOp FloatLeOp = LE
2102 cmpOp DoubleGtOp = GTT
2103 cmpOp DoubleGeOp = GE
2104 cmpOp DoubleEqOp = EQQ
2105 cmpOp DoubleNeOp = NE
2106 cmpOp DoubleLtOp = LTT
2107 cmpOp DoubleLeOp = LE
2109 genCondJump lbl (StPrim op [x, y])
2111 = trivialFCode pr instr x y `thenNat` \ register ->
2112 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2114 code = registerCode register tmp
2115 result = registerName register tmp
2116 target = ImmCLbl lbl
2118 returnNat (code . mkSeqInstr (BF cond result target))
2120 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2122 fltCmpOp op = case op of
2136 (instr, cond) = case op of
2137 FloatGtOp -> (FCMP TF LE, EQQ)
2138 FloatGeOp -> (FCMP TF LTT, EQQ)
2139 FloatEqOp -> (FCMP TF EQQ, NE)
2140 FloatNeOp -> (FCMP TF EQQ, EQQ)
2141 FloatLtOp -> (FCMP TF LTT, NE)
2142 FloatLeOp -> (FCMP TF LE, NE)
2143 DoubleGtOp -> (FCMP TF LE, EQQ)
2144 DoubleGeOp -> (FCMP TF LTT, EQQ)
2145 DoubleEqOp -> (FCMP TF EQQ, NE)
2146 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2147 DoubleLtOp -> (FCMP TF LTT, NE)
2148 DoubleLeOp -> (FCMP TF LE, NE)
2150 genCondJump lbl (StPrim op [x, y])
2151 = trivialCode instr x y `thenNat` \ register ->
2152 getNewRegNCG IntRep `thenNat` \ tmp ->
2154 code = registerCode register tmp
2155 result = registerName register tmp
2156 target = ImmCLbl lbl
2158 returnNat (code . mkSeqInstr (BI cond result target))
2160 (instr, cond) = case op of
2161 CharGtOp -> (CMP LE, EQQ)
2162 CharGeOp -> (CMP LTT, EQQ)
2163 CharEqOp -> (CMP EQQ, NE)
2164 CharNeOp -> (CMP EQQ, EQQ)
2165 CharLtOp -> (CMP LTT, NE)
2166 CharLeOp -> (CMP LE, NE)
2167 IntGtOp -> (CMP LE, EQQ)
2168 IntGeOp -> (CMP LTT, EQQ)
2169 IntEqOp -> (CMP EQQ, NE)
2170 IntNeOp -> (CMP EQQ, EQQ)
2171 IntLtOp -> (CMP LTT, NE)
2172 IntLeOp -> (CMP LE, NE)
2173 WordGtOp -> (CMP ULE, EQQ)
2174 WordGeOp -> (CMP ULT, EQQ)
2175 WordEqOp -> (CMP EQQ, NE)
2176 WordNeOp -> (CMP EQQ, EQQ)
2177 WordLtOp -> (CMP ULT, NE)
2178 WordLeOp -> (CMP ULE, NE)
2179 AddrGtOp -> (CMP ULE, EQQ)
2180 AddrGeOp -> (CMP ULT, EQQ)
2181 AddrEqOp -> (CMP EQQ, NE)
2182 AddrNeOp -> (CMP EQQ, EQQ)
2183 AddrLtOp -> (CMP ULT, NE)
2184 AddrLeOp -> (CMP ULE, NE)
2186 #endif {- alpha_TARGET_ARCH -}
2187 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2188 #if i386_TARGET_ARCH
2190 genCondJump lbl bool
2191 = getCondCode bool `thenNat` \ condition ->
2193 code = condCode condition
2194 cond = condName condition
2195 target = ImmCLbl lbl
2197 returnNat (code `snocOL` JXX cond lbl)
2199 #endif {- i386_TARGET_ARCH -}
2200 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2201 #if sparc_TARGET_ARCH
2203 genCondJump lbl bool
2204 = getCondCode bool `thenNat` \ condition ->
2206 code = condCode condition
2207 cond = condName condition
2208 target = ImmCLbl lbl
2213 if condFloat condition
2214 then [NOP, BF cond False target, NOP]
2215 else [BI cond False target, NOP]
2219 #endif {- sparc_TARGET_ARCH -}
2222 %************************************************************************
2224 \subsection{Generating C calls}
2226 %************************************************************************
2228 Now the biggest nightmare---calls. Most of the nastiness is buried in
2229 @get_arg@, which moves the arguments to the correct registers/stack
2230 locations. Apart from that, the code is easy.
2232 (If applicable) Do not fill the delay slots here; you will confuse the
2237 :: FAST_STRING -- function to call
2239 -> PrimRep -- type of the result
2240 -> [StixTree] -- arguments (of mixed type)
2243 #if alpha_TARGET_ARCH
2245 genCCall fn cconv kind args
2246 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2247 `thenNat` \ ((unused,_), argCode) ->
2249 nRegs = length allArgRegs - length unused
2250 code = asmSeqThen (map ($ []) argCode)
2253 LDA pv (AddrImm (ImmLab (ptext fn))),
2254 JSR ra (AddrReg pv) nRegs,
2255 LDGP gp (AddrReg ra)]
2257 ------------------------
2258 {- Try to get a value into a specific register (or registers) for
2259 a call. The first 6 arguments go into the appropriate
2260 argument register (separate registers for integer and floating
2261 point arguments, but used in lock-step), and the remaining
2262 arguments are dumped to the stack, beginning at 0(sp). Our
2263 first argument is a pair of the list of remaining argument
2264 registers to be assigned for this call and the next stack
2265 offset to use for overflowing arguments. This way,
2266 @get_Arg@ can be applied to all of a call's arguments using
2270 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2271 -> StixTree -- Current argument
2272 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2274 -- We have to use up all of our argument registers first...
2276 get_arg ((iDst,fDst):dsts, offset) arg
2277 = getRegister arg `thenNat` \ register ->
2279 reg = if isFloatingRep pk then fDst else iDst
2280 code = registerCode register reg
2281 src = registerName register reg
2282 pk = registerRep register
2285 if isFloatingRep pk then
2286 ((dsts, offset), if isFixed register then
2287 code . mkSeqInstr (FMOV src fDst)
2290 ((dsts, offset), if isFixed register then
2291 code . mkSeqInstr (OR src (RIReg src) iDst)
2294 -- Once we have run out of argument registers, we move to the
2297 get_arg ([], offset) arg
2298 = getRegister arg `thenNat` \ register ->
2299 getNewRegNCG (registerRep register)
2302 code = registerCode register tmp
2303 src = registerName register tmp
2304 pk = registerRep register
2305 sz = primRepToSize pk
2307 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2309 #endif {- alpha_TARGET_ARCH -}
2310 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2311 #if i386_TARGET_ARCH
2313 genCCall fn cconv kind [StInt i]
2314 | fn == SLIT ("PerformGC_wrapper")
2316 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2317 CALL (ImmLit (ptext (if underscorePrefix
2318 then (SLIT ("_PerformGC_wrapper"))
2319 else (SLIT ("PerformGC_wrapper")))))
2325 genCCall fn cconv kind args
2326 = mapNat get_call_arg
2327 (reverse args) `thenNat` \ sizes_n_codes ->
2328 getDeltaNat `thenNat` \ delta ->
2329 let (sizes, codes) = unzip sizes_n_codes
2330 tot_arg_size = sum sizes
2331 code2 = concatOL codes
2334 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2335 DELTA (delta + tot_arg_size)
2338 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2339 returnNat (code2 `appOL` call)
2342 -- function names that begin with '.' are assumed to be special
2343 -- internally generated names like '.mul,' which don't get an
2344 -- underscore prefix
2345 -- ToDo:needed (WDP 96/03) ???
2346 fn__2 = case (_HEAD_ fn) of
2347 '.' -> ImmLit (ptext fn)
2348 _ -> ImmLab False (ptext fn)
2355 get_call_arg :: StixTree{-current argument-}
2356 -> NatM (Int, InstrBlock) -- argsz, code
2359 = get_op arg `thenNat` \ (code, reg, sz) ->
2360 getDeltaNat `thenNat` \ delta ->
2361 arg_size sz `bind` \ size ->
2362 setDeltaNat (delta-size) `thenNat` \ _ ->
2363 if (case sz of DF -> True; F -> True; _ -> False)
2364 then returnNat (size,
2366 toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
2368 GST DF reg (AddrBaseIndex (Just esp)
2372 else returnNat (size,
2374 PUSH L (OpReg reg) `snocOL`
2380 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2383 = getRegister op `thenNat` \ register ->
2384 getNewRegNCG (registerRep register)
2387 code = registerCode register tmp
2388 reg = registerName register tmp
2389 pk = registerRep register
2390 sz = primRepToSize pk
2392 returnNat (code, reg, sz)
2394 #endif {- i386_TARGET_ARCH -}
2395 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2396 #if sparc_TARGET_ARCH
2398 genCCall fn cconv kind args
2399 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2400 `thenNat` \ ((unused,_), argCode) ->
2402 nRegs = length allArgRegs - length unused
2403 call = CALL fn__2 nRegs False
2404 code = concatOL argCode
2406 returnNat (code `snocOL` call `snocOL` NOP)
2408 -- function names that begin with '.' are assumed to be special
2409 -- internally generated names like '.mul,' which don't get an
2410 -- underscore prefix
2411 -- ToDo:needed (WDP 96/03) ???
2412 fn__2 = case (_HEAD_ fn) of
2413 '.' -> ImmLit (ptext fn)
2414 _ -> ImmLab False (ptext fn)
2416 ------------------------------------
2417 {- Try to get a value into a specific register (or registers) for
2418 a call. The SPARC calling convention is an absolute
2419 nightmare. The first 6x32 bits of arguments are mapped into
2420 %o0 through %o5, and the remaining arguments are dumped to the
2421 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2422 first argument is a pair of the list of remaining argument
2423 registers to be assigned for this call and the next stack
2424 offset to use for overflowing arguments. This way,
2425 @get_arg@ can be applied to all of a call's arguments using
2429 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2430 -> StixTree -- Current argument
2431 -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2433 -- We have to use up all of our argument registers first...
2435 get_arg (dst:dsts, offset) arg
2436 = getRegister arg `thenNat` \ register ->
2437 getNewRegNCG (registerRep register)
2440 reg = if isFloatingRep pk then tmp else dst
2441 code = registerCode register reg
2442 src = registerName register reg
2443 pk = registerRep register
2449 [] -> ( ([], offset + 1),
2451 -- conveniently put the second part in the right stack
2452 -- location, and load the first part into %o5
2453 ST DF src (spRel (offset - 1)) `snocOL`
2454 LD W (spRel (offset - 1)) dst
2457 -> ( (dsts__2, offset),
2459 ST DF src (spRel (-2)) `snocOL`
2460 LD W (spRel (-2)) dst `snocOL`
2461 LD W (spRel (-1)) dst__2
2464 -> ( (dsts, offset),
2466 ST F src (spRel (-2)) `snocOL`
2467 LD W (spRel (-2)) dst
2469 _ -> ( (dsts, offset),
2471 then code `snocOL` OR False g0 (RIReg src) dst
2475 -- Once we have run out of argument registers, we move to the
2478 get_arg ([], offset) arg
2479 = getRegister arg `thenNat` \ register ->
2480 getNewRegNCG (registerRep register)
2483 code = registerCode register tmp
2484 src = registerName register tmp
2485 pk = registerRep register
2486 sz = primRepToSize pk
2487 words = if pk == DoubleRep then 2 else 1
2489 returnNat ( ([], offset + words),
2490 code `snocOL` ST sz src (spRel offset) )
2492 #endif {- sparc_TARGET_ARCH -}
2495 %************************************************************************
2497 \subsection{Support bits}
2499 %************************************************************************
2501 %************************************************************************
2503 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2505 %************************************************************************
2507 Turn those condition codes into integers now (when they appear on
2508 the right hand side of an assignment).
2510 (If applicable) Do not fill the delay slots here; you will confuse the
2514 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2516 #if alpha_TARGET_ARCH
2517 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2518 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2519 #endif {- alpha_TARGET_ARCH -}
2521 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2522 #if i386_TARGET_ARCH
2525 = condIntCode cond x y `thenNat` \ condition ->
2526 getNewRegNCG IntRep `thenNat` \ tmp ->
2528 code = condCode condition
2529 cond = condName condition
2530 code__2 dst = code `appOL` toOL [
2531 SETCC cond (OpReg tmp),
2532 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2533 MOV L (OpReg tmp) (OpReg dst)]
2535 returnNat (Any IntRep code__2)
2538 = getNatLabelNCG `thenNat` \ lbl1 ->
2539 getNatLabelNCG `thenNat` \ lbl2 ->
2540 condFltCode cond x y `thenNat` \ condition ->
2542 code = condCode condition
2543 cond = condName condition
2544 code__2 dst = code `appOL` toOL [
2546 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2549 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2552 returnNat (Any IntRep code__2)
2554 #endif {- i386_TARGET_ARCH -}
2555 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2556 #if sparc_TARGET_ARCH
2558 condIntReg EQQ x (StInt 0)
2559 = getRegister x `thenNat` \ register ->
2560 getNewRegNCG IntRep `thenNat` \ tmp ->
2562 code = registerCode register tmp
2563 src = registerName register tmp
2564 code__2 dst = code `appOL` toOL [
2565 SUB False True g0 (RIReg src) g0,
2566 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2568 returnNat (Any IntRep code__2)
2571 = getRegister x `thenNat` \ register1 ->
2572 getRegister y `thenNat` \ register2 ->
2573 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2574 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2576 code1 = registerCode register1 tmp1
2577 src1 = registerName register1 tmp1
2578 code2 = registerCode register2 tmp2
2579 src2 = registerName register2 tmp2
2580 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2581 XOR False src1 (RIReg src2) dst,
2582 SUB False True g0 (RIReg dst) g0,
2583 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2585 returnNat (Any IntRep code__2)
2587 condIntReg NE x (StInt 0)
2588 = getRegister x `thenNat` \ register ->
2589 getNewRegNCG IntRep `thenNat` \ tmp ->
2591 code = registerCode register tmp
2592 src = registerName register tmp
2593 code__2 dst = code `appOL` toOL [
2594 SUB False True g0 (RIReg src) g0,
2595 ADD True False g0 (RIImm (ImmInt 0)) dst]
2597 returnNat (Any IntRep code__2)
2600 = getRegister x `thenNat` \ register1 ->
2601 getRegister y `thenNat` \ register2 ->
2602 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2603 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2605 code1 = registerCode register1 tmp1
2606 src1 = registerName register1 tmp1
2607 code2 = registerCode register2 tmp2
2608 src2 = registerName register2 tmp2
2609 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2610 XOR False src1 (RIReg src2) dst,
2611 SUB False True g0 (RIReg dst) g0,
2612 ADD True False g0 (RIImm (ImmInt 0)) dst]
2614 returnNat (Any IntRep code__2)
2617 = getNatLabelNCG `thenNat` \ lbl1 ->
2618 getNatLabelNCG `thenNat` \ lbl2 ->
2619 condIntCode cond x y `thenNat` \ condition ->
2621 code = condCode condition
2622 cond = condName condition
2623 code__2 dst = code `appOL` toOL [
2624 BI cond False (ImmCLbl lbl1), NOP,
2625 OR False g0 (RIImm (ImmInt 0)) dst,
2626 BI ALWAYS False (ImmCLbl lbl2), NOP,
2628 OR False g0 (RIImm (ImmInt 1)) dst,
2631 returnNat (Any IntRep code__2)
2634 = getNatLabelNCG `thenNat` \ lbl1 ->
2635 getNatLabelNCG `thenNat` \ lbl2 ->
2636 condFltCode cond x y `thenNat` \ condition ->
2638 code = condCode condition
2639 cond = condName condition
2640 code__2 dst = code `appOL` toOL [
2642 BF cond False (ImmCLbl lbl1), NOP,
2643 OR False g0 (RIImm (ImmInt 0)) dst,
2644 BI ALWAYS False (ImmCLbl lbl2), NOP,
2646 OR False g0 (RIImm (ImmInt 1)) dst,
2649 returnNat (Any IntRep code__2)
2651 #endif {- sparc_TARGET_ARCH -}
2654 %************************************************************************
2656 \subsubsection{@trivial*Code@: deal with trivial instructions}
2658 %************************************************************************
2660 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2661 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2662 for constants on the right hand side, because that's where the generic
2663 optimizer will have put them.
2665 Similarly, for unary instructions, we don't have to worry about
2666 matching an StInt as the argument, because genericOpt will already
2667 have handled the constant-folding.
2671 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2672 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2673 -> Maybe (Operand -> Operand -> Instr)
2674 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2676 -> StixTree -> StixTree -- the two arguments
2681 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2682 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2683 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2685 -> StixTree -> StixTree -- the two arguments
2689 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2690 ,IF_ARCH_i386 ((Operand -> Instr)
2691 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2693 -> StixTree -- the one argument
2698 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2699 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2700 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2702 -> StixTree -- the one argument
2705 #if alpha_TARGET_ARCH
2707 trivialCode instr x (StInt y)
2709 = getRegister x `thenNat` \ register ->
2710 getNewRegNCG IntRep `thenNat` \ tmp ->
2712 code = registerCode register tmp
2713 src1 = registerName register tmp
2714 src2 = ImmInt (fromInteger y)
2715 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2717 returnNat (Any IntRep code__2)
2719 trivialCode instr x y
2720 = getRegister x `thenNat` \ register1 ->
2721 getRegister y `thenNat` \ register2 ->
2722 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2723 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2725 code1 = registerCode register1 tmp1 []
2726 src1 = registerName register1 tmp1
2727 code2 = registerCode register2 tmp2 []
2728 src2 = registerName register2 tmp2
2729 code__2 dst = asmSeqThen [code1, code2] .
2730 mkSeqInstr (instr src1 (RIReg src2) dst)
2732 returnNat (Any IntRep code__2)
2735 trivialUCode instr x
2736 = getRegister x `thenNat` \ register ->
2737 getNewRegNCG IntRep `thenNat` \ tmp ->
2739 code = registerCode register tmp
2740 src = registerName register tmp
2741 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2743 returnNat (Any IntRep code__2)
2746 trivialFCode _ instr x y
2747 = getRegister x `thenNat` \ register1 ->
2748 getRegister y `thenNat` \ register2 ->
2749 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2750 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2752 code1 = registerCode register1 tmp1
2753 src1 = registerName register1 tmp1
2755 code2 = registerCode register2 tmp2
2756 src2 = registerName register2 tmp2
2758 code__2 dst = asmSeqThen [code1 [], code2 []] .
2759 mkSeqInstr (instr src1 src2 dst)
2761 returnNat (Any DoubleRep code__2)
2763 trivialUFCode _ instr x
2764 = getRegister x `thenNat` \ register ->
2765 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2767 code = registerCode register tmp
2768 src = registerName register tmp
2769 code__2 dst = code . mkSeqInstr (instr src dst)
2771 returnNat (Any DoubleRep code__2)
2773 #endif {- alpha_TARGET_ARCH -}
2774 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2775 #if i386_TARGET_ARCH
2777 The Rules of the Game are:
2779 * You cannot assume anything about the destination register dst;
2780 it may be anything, including a fixed reg.
2782 * You may compute an operand into a fixed reg, but you may not
2783 subsequently change the contents of that fixed reg. If you
2784 want to do so, first copy the value either to a temporary
2785 or into dst. You are free to modify dst even if it happens
2786 to be a fixed reg -- that's not your problem.
2788 * You cannot assume that a fixed reg will stay live over an
2789 arbitrary computation. The same applies to the dst reg.
2791 * Temporary regs obtained from getNewRegNCG are distinct from
2792 each other and from all other regs, and stay live over
2793 arbitrary computations.
2797 trivialCode instr maybe_revinstr a b
2800 = getRegister a `thenNat` \ rega ->
2803 then registerCode rega dst `bind` \ code_a ->
2805 instr (OpImm imm_b) (OpReg dst)
2806 else registerCodeF rega `bind` \ code_a ->
2807 registerNameF rega `bind` \ r_a ->
2809 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2810 instr (OpImm imm_b) (OpReg dst)
2812 returnNat (Any IntRep mkcode)
2815 = getRegister b `thenNat` \ regb ->
2816 getNewRegNCG IntRep `thenNat` \ tmp ->
2817 let revinstr_avail = maybeToBool maybe_revinstr
2818 revinstr = case maybe_revinstr of Just ri -> ri
2822 then registerCode regb dst `bind` \ code_b ->
2824 revinstr (OpImm imm_a) (OpReg dst)
2825 else registerCodeF regb `bind` \ code_b ->
2826 registerNameF regb `bind` \ r_b ->
2828 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2829 revinstr (OpImm imm_a) (OpReg dst)
2833 then registerCode regb tmp `bind` \ code_b ->
2835 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2836 instr (OpReg tmp) (OpReg dst)
2837 else registerCodeF regb `bind` \ code_b ->
2838 registerNameF regb `bind` \ r_b ->
2840 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2841 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2842 instr (OpReg tmp) (OpReg dst)
2844 returnNat (Any IntRep mkcode)
2847 = getRegister a `thenNat` \ rega ->
2848 getRegister b `thenNat` \ regb ->
2849 getNewRegNCG IntRep `thenNat` \ tmp ->
2851 = case (isAny rega, isAny regb) of
2853 -> registerCode regb tmp `bind` \ code_b ->
2854 registerCode rega dst `bind` \ code_a ->
2857 instr (OpReg tmp) (OpReg dst)
2859 -> registerCode rega tmp `bind` \ code_a ->
2860 registerCodeF regb `bind` \ code_b ->
2861 registerNameF regb `bind` \ r_b ->
2864 instr (OpReg r_b) (OpReg tmp) `snocOL`
2865 MOV L (OpReg tmp) (OpReg dst)
2867 -> registerCode regb tmp `bind` \ code_b ->
2868 registerCodeF rega `bind` \ code_a ->
2869 registerNameF rega `bind` \ r_a ->
2872 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2873 instr (OpReg tmp) (OpReg dst)
2875 -> registerCodeF rega `bind` \ code_a ->
2876 registerNameF rega `bind` \ r_a ->
2877 registerCodeF regb `bind` \ code_b ->
2878 registerNameF regb `bind` \ r_b ->
2880 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2882 instr (OpReg r_b) (OpReg tmp) `snocOL`
2883 MOV L (OpReg tmp) (OpReg dst)
2885 returnNat (Any IntRep mkcode)
2888 maybe_imm_a = maybeImm a
2889 is_imm_a = maybeToBool maybe_imm_a
2890 imm_a = case maybe_imm_a of Just imm -> imm
2892 maybe_imm_b = maybeImm b
2893 is_imm_b = maybeToBool maybe_imm_b
2894 imm_b = case maybe_imm_b of Just imm -> imm
2898 trivialUCode instr x
2899 = getRegister x `thenNat` \ register ->
2901 code__2 dst = let code = registerCode register dst
2902 src = registerName register dst
2904 if isFixed register && dst /= src
2905 then toOL [MOV L (OpReg src) (OpReg dst),
2907 else unitOL (instr (OpReg src))
2909 returnNat (Any IntRep code__2)
2912 trivialFCode pk instr x y
2913 = getRegister x `thenNat` \ register1 ->
2914 getRegister y `thenNat` \ register2 ->
2915 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2916 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2918 code1 = registerCode register1 tmp1
2919 src1 = registerName register1 tmp1
2921 code2 = registerCode register2 tmp2
2922 src2 = registerName register2 tmp2
2925 -- treat the common case specially: both operands in
2927 | isAny register1 && isAny register2
2930 instr (primRepToSize pk) src1 src2 dst
2932 -- be paranoid (and inefficient)
2934 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2936 instr (primRepToSize pk) tmp1 src2 dst
2938 returnNat (Any DoubleRep code__2)
2942 trivialUFCode pk instr x
2943 = getRegister x `thenNat` \ register ->
2944 getNewRegNCG pk `thenNat` \ tmp ->
2946 code = registerCode register tmp
2947 src = registerName register tmp
2948 code__2 dst = code `snocOL` instr src dst
2950 returnNat (Any pk code__2)
2952 #endif {- i386_TARGET_ARCH -}
2953 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2954 #if sparc_TARGET_ARCH
2956 trivialCode instr x (StInt y)
2958 = getRegister x `thenNat` \ register ->
2959 getNewRegNCG IntRep `thenNat` \ tmp ->
2961 code = registerCode register tmp
2962 src1 = registerName register tmp
2963 src2 = ImmInt (fromInteger y)
2964 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
2966 returnNat (Any IntRep code__2)
2968 trivialCode instr x y
2969 = getRegister x `thenNat` \ register1 ->
2970 getRegister y `thenNat` \ register2 ->
2971 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2972 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2974 code1 = registerCode register1 tmp1
2975 src1 = registerName register1 tmp1
2976 code2 = registerCode register2 tmp2
2977 src2 = registerName register2 tmp2
2978 code__2 dst = code1 `appOL` code2 `snocOL`
2979 instr src1 (RIReg src2) dst
2981 returnNat (Any IntRep code__2)
2984 trivialFCode pk instr x y
2985 = getRegister x `thenNat` \ register1 ->
2986 getRegister y `thenNat` \ register2 ->
2987 getNewRegNCG (registerRep register1)
2989 getNewRegNCG (registerRep register2)
2991 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2993 promote x = FxTOy F DF x tmp
2995 pk1 = registerRep register1
2996 code1 = registerCode register1 tmp1
2997 src1 = registerName register1 tmp1
2999 pk2 = registerRep register2
3000 code2 = registerCode register2 tmp2
3001 src2 = registerName register2 tmp2
3005 code1 `appOL` code2 `snocOL`
3006 instr (primRepToSize pk) src1 src2 dst
3007 else if pk1 == FloatRep then
3008 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3009 instr DF tmp src2 dst
3011 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3012 instr DF src1 tmp dst
3014 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3017 trivialUCode instr x
3018 = getRegister x `thenNat` \ register ->
3019 getNewRegNCG IntRep `thenNat` \ tmp ->
3021 code = registerCode register tmp
3022 src = registerName register tmp
3023 code__2 dst = code `snocOL` instr (RIReg src) dst
3025 returnNat (Any IntRep code__2)
3028 trivialUFCode pk instr x
3029 = getRegister x `thenNat` \ register ->
3030 getNewRegNCG pk `thenNat` \ tmp ->
3032 code = registerCode register tmp
3033 src = registerName register tmp
3034 code__2 dst = code `snocOL` instr src dst
3036 returnNat (Any pk code__2)
3038 #endif {- sparc_TARGET_ARCH -}
3041 %************************************************************************
3043 \subsubsection{Coercing to/from integer/floating-point...}
3045 %************************************************************************
3047 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3048 to be generated. Here we just change the type on the Register passed
3049 on up. The code is machine-independent.
3051 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3052 conversions. We have to store temporaries in memory to move
3053 between the integer and the floating point register sets.
3056 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3057 coerceFltCode :: StixTree -> NatM Register
3059 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3060 coerceFP2Int :: StixTree -> NatM Register
3063 = getRegister x `thenNat` \ register ->
3066 Fixed _ reg code -> Fixed pk reg code
3067 Any _ code -> Any pk code
3072 = getRegister x `thenNat` \ register ->
3075 Fixed _ reg code -> Fixed DoubleRep reg code
3076 Any _ code -> Any DoubleRep code
3081 #if alpha_TARGET_ARCH
3084 = getRegister x `thenNat` \ register ->
3085 getNewRegNCG IntRep `thenNat` \ reg ->
3087 code = registerCode register reg
3088 src = registerName register reg
3090 code__2 dst = code . mkSeqInstrs [
3092 LD TF dst (spRel 0),
3095 returnNat (Any DoubleRep code__2)
3099 = getRegister x `thenNat` \ register ->
3100 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3102 code = registerCode register tmp
3103 src = registerName register tmp
3105 code__2 dst = code . mkSeqInstrs [
3107 ST TF tmp (spRel 0),
3110 returnNat (Any IntRep code__2)
3112 #endif {- alpha_TARGET_ARCH -}
3113 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3114 #if i386_TARGET_ARCH
3117 = getRegister x `thenNat` \ register ->
3118 getNewRegNCG IntRep `thenNat` \ reg ->
3120 code = registerCode register reg
3121 src = registerName register reg
3122 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3123 code__2 dst = code `snocOL` opc src dst
3125 returnNat (Any pk code__2)
3129 = getRegister x `thenNat` \ register ->
3130 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3132 code = registerCode register tmp
3133 src = registerName register tmp
3134 pk = registerRep register
3136 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3137 code__2 dst = code `snocOL` opc src dst
3139 returnNat (Any IntRep code__2)
3141 #endif {- i386_TARGET_ARCH -}
3142 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3143 #if sparc_TARGET_ARCH
3146 = getRegister x `thenNat` \ register ->
3147 getNewRegNCG IntRep `thenNat` \ reg ->
3149 code = registerCode register reg
3150 src = registerName register reg
3152 code__2 dst = code `appOL` toOL [
3153 ST W src (spRel (-2)),
3154 LD W (spRel (-2)) dst,
3155 FxTOy W (primRepToSize pk) dst dst]
3157 returnNat (Any pk code__2)
3161 = getRegister x `thenNat` \ register ->
3162 getNewRegNCG IntRep `thenNat` \ reg ->
3163 getNewRegNCG FloatRep `thenNat` \ tmp ->
3165 code = registerCode register reg
3166 src = registerName register reg
3167 pk = registerRep register
3169 code__2 dst = code `appOL` toOL [
3170 FxTOy (primRepToSize pk) W src tmp,
3171 ST W tmp (spRel (-2)),
3172 LD W (spRel (-2)) dst]
3174 returnNat (Any IntRep code__2)
3176 #endif {- sparc_TARGET_ARCH -}
3179 %************************************************************************
3181 \subsubsection{Coercing integer to @Char@...}
3183 %************************************************************************
3185 Integer to character conversion. Where applicable, we try to do this
3186 in one step if the original object is in memory.
3189 chrCode :: StixTree -> NatM Register
3191 #if alpha_TARGET_ARCH
3194 = getRegister x `thenNat` \ register ->
3195 getNewRegNCG IntRep `thenNat` \ reg ->
3197 code = registerCode register reg
3198 src = registerName register reg
3199 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3201 returnNat (Any IntRep code__2)
3203 #endif {- alpha_TARGET_ARCH -}
3204 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3205 #if i386_TARGET_ARCH
3208 = getRegister x `thenNat` \ register ->
3211 code = registerCode register dst
3212 src = registerName register dst
3214 if isFixed register && src /= dst
3215 then toOL [MOV L (OpReg src) (OpReg dst),
3216 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3217 else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3219 returnNat (Any IntRep code__2)
3221 #endif {- i386_TARGET_ARCH -}
3222 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3223 #if sparc_TARGET_ARCH
3225 chrCode (StInd pk mem)
3226 = getAmode mem `thenNat` \ amode ->
3228 code = amodeCode amode
3229 src = amodeAddr amode
3230 src_off = addrOffset src 3
3231 src__2 = case src_off of Just x -> x
3232 code__2 dst = if maybeToBool src_off then
3233 code `snocOL` LD BU src__2 dst
3236 LD (primRepToSize pk) src dst `snocOL`
3237 AND False dst (RIImm (ImmInt 255)) dst
3239 returnNat (Any pk code__2)
3242 = getRegister x `thenNat` \ register ->
3243 getNewRegNCG IntRep `thenNat` \ reg ->
3245 code = registerCode register reg
3246 src = registerName register reg
3247 code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
3249 returnNat (Any IntRep code__2)
3251 #endif {- sparc_TARGET_ARCH -}