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, pprCLabel_asm, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 pprStixTree, ppStixReg,
31 NatM, thenNat, returnNat, mapNat,
32 mapAndUnzipNat, mapAccumLNat,
33 getDeltaNat, setDeltaNat
36 import CmdLineOpts ( opt_Static )
42 @InstrBlock@s are the insn sequences generated by the insn selectors.
43 They are really trees of insns to facilitate fast appending, where a
44 left-to-right traversal (pre-order?) yields the insns in the correct
49 type InstrBlock = OrdList Instr
55 Code extractor for an entire stix tree---stix statement level.
58 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
60 stmt2Instrs stmt = case stmt of
61 StComment s -> returnNat (unitOL (COMMENT s))
62 StSegment seg -> returnNat (unitOL (SEGMENT seg))
64 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
66 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
69 StLabel lab -> returnNat (unitOL (LABEL lab))
71 StJump arg -> genJump (derefDLL arg)
72 StCondJump lab arg -> genCondJump lab (derefDLL arg)
74 -- A call returning void, ie one done for its side-effects
75 StCall fn cconv VoidRep args -> genCCall fn
76 cconv VoidRep (map derefDLL args)
79 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
80 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
83 -- When falling through on the Alpha, we still have to load pv
84 -- with the address of the next routine, so that it can load gp.
85 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
89 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
90 returnNat (DATA (primRepToSize kind) imms
91 `consOL` concatOL codes)
93 getData :: StixTree -> NatM (InstrBlock, Imm)
95 getData (StInt i) = returnNat (nilOL, ImmInteger i)
96 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
97 getData (StFloat d) = returnNat (nilOL, ImmFloat 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)
136 _ -> pprPanic "derefDLL: unhandled case"
140 %************************************************************************
142 \subsection{General things for putting together code sequences}
144 %************************************************************************
147 mangleIndexTree :: StixTree -> StixTree
149 mangleIndexTree (StIndex pk base (StInt i))
150 = StPrim IntAddOp [base, off]
152 off = StInt (i * sizeOf pk)
154 mangleIndexTree (StIndex pk base off)
158 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
159 if s == 0 then off else StPrim SllOp [off, StInt s]
162 shift DoubleRep = 3::Integer
163 shift CharRep = 0::Integer
164 shift _ = IF_ARCH_alpha(3,2)
168 maybeImm :: StixTree -> Maybe Imm
172 maybeImm (StIndex rep (StCLbl l) (StInt off))
173 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
175 | i >= toInteger minInt && i <= toInteger maxInt
176 = Just (ImmInt (fromInteger i))
178 = Just (ImmInteger i)
183 %************************************************************************
185 \subsection{The @Register@ type}
187 %************************************************************************
189 @Register@s passed up the tree. If the stix code forces the register
190 to live in a pre-decided machine register, it comes out as @Fixed@;
191 otherwise, it comes out as @Any@, and the parent can decide which
192 register to put it in.
196 = Fixed PrimRep Reg InstrBlock
197 | Any PrimRep (Reg -> InstrBlock)
199 registerCode :: Register -> Reg -> InstrBlock
200 registerCode (Fixed _ _ code) reg = code
201 registerCode (Any _ code) reg = code reg
203 registerCodeF (Fixed _ _ code) = code
204 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
206 registerCodeA (Any _ code) = code
207 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
209 registerName :: Register -> Reg -> Reg
210 registerName (Fixed _ reg _) _ = reg
211 registerName (Any _ _) reg = reg
213 registerNameF (Fixed _ reg _) = reg
214 registerNameF (Any _ _) = pprPanic "registerNameF" empty
216 registerRep :: Register -> PrimRep
217 registerRep (Fixed pk _ _) = pk
218 registerRep (Any pk _) = pk
220 {-# INLINE registerCode #-}
221 {-# INLINE registerCodeF #-}
222 {-# INLINE registerName #-}
223 {-# INLINE registerNameF #-}
224 {-# INLINE registerRep #-}
225 {-# INLINE isFixed #-}
228 isFixed, isAny :: Register -> Bool
229 isFixed (Fixed _ _ _) = True
230 isFixed (Any _ _) = False
232 isAny = not . isFixed
235 Generate code to get a subtree into a @Register@:
237 getRegister :: StixTree -> NatM Register
239 getRegister (StReg (StixMagicId stgreg))
240 = case (magicIdRegMaybe stgreg) of
241 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
244 getRegister (StReg (StixTemp u pk))
245 = returnNat (Fixed pk (mkVReg u pk) nilOL)
247 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
249 getRegister (StCall fn cconv kind args)
250 = genCCall fn cconv kind args `thenNat` \ call ->
251 returnNat (Fixed kind reg call)
253 reg = if isFloatingRep kind
254 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
255 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
257 getRegister (StString s)
258 = getNatLabelNCG `thenNat` \ lbl ->
260 imm_lbl = ImmCLbl lbl
265 ASCII True (_UNPK_ s),
267 #if alpha_TARGET_ARCH
268 LDA dst (AddrImm imm_lbl)
271 MOV L (OpImm imm_lbl) (OpReg dst)
273 #if sparc_TARGET_ARCH
274 SETHI (HI imm_lbl) dst,
275 OR False dst (RIImm (LO imm_lbl)) dst
279 returnNat (Any PtrRep code)
283 -- end of machine-"independent" bit; here we go on the rest...
285 #if alpha_TARGET_ARCH
287 getRegister (StDouble d)
288 = getNatLabelNCG `thenNat` \ lbl ->
289 getNewRegNCG PtrRep `thenNat` \ tmp ->
290 let code dst = mkSeqInstrs [
293 DATA TF [ImmLab (rational d)],
295 LDA tmp (AddrImm (ImmCLbl lbl)),
296 LD TF dst (AddrReg tmp)]
298 returnNat (Any DoubleRep code)
300 getRegister (StPrim primop [x]) -- unary PrimOps
302 IntNegOp -> trivialUCode (NEG Q False) x
304 NotOp -> trivialUCode NOT x
306 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
307 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
309 OrdOp -> coerceIntCode IntRep x
312 Float2IntOp -> coerceFP2Int x
313 Int2FloatOp -> coerceInt2FP pr x
314 Double2IntOp -> coerceFP2Int x
315 Int2DoubleOp -> coerceInt2FP pr x
317 Double2FloatOp -> coerceFltCode x
318 Float2DoubleOp -> coerceFltCode x
320 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
322 fn = case other_op of
323 FloatExpOp -> SLIT("exp")
324 FloatLogOp -> SLIT("log")
325 FloatSqrtOp -> SLIT("sqrt")
326 FloatSinOp -> SLIT("sin")
327 FloatCosOp -> SLIT("cos")
328 FloatTanOp -> SLIT("tan")
329 FloatAsinOp -> SLIT("asin")
330 FloatAcosOp -> SLIT("acos")
331 FloatAtanOp -> SLIT("atan")
332 FloatSinhOp -> SLIT("sinh")
333 FloatCoshOp -> SLIT("cosh")
334 FloatTanhOp -> SLIT("tanh")
335 DoubleExpOp -> SLIT("exp")
336 DoubleLogOp -> SLIT("log")
337 DoubleSqrtOp -> SLIT("sqrt")
338 DoubleSinOp -> SLIT("sin")
339 DoubleCosOp -> SLIT("cos")
340 DoubleTanOp -> SLIT("tan")
341 DoubleAsinOp -> SLIT("asin")
342 DoubleAcosOp -> SLIT("acos")
343 DoubleAtanOp -> SLIT("atan")
344 DoubleSinhOp -> SLIT("sinh")
345 DoubleCoshOp -> SLIT("cosh")
346 DoubleTanhOp -> SLIT("tanh")
348 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
350 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
352 CharGtOp -> trivialCode (CMP LTT) y x
353 CharGeOp -> trivialCode (CMP LE) y x
354 CharEqOp -> trivialCode (CMP EQQ) x y
355 CharNeOp -> int_NE_code x y
356 CharLtOp -> trivialCode (CMP LTT) x y
357 CharLeOp -> trivialCode (CMP LE) x y
359 IntGtOp -> trivialCode (CMP LTT) y x
360 IntGeOp -> trivialCode (CMP LE) y x
361 IntEqOp -> trivialCode (CMP EQQ) x y
362 IntNeOp -> int_NE_code x y
363 IntLtOp -> trivialCode (CMP LTT) x y
364 IntLeOp -> trivialCode (CMP LE) x y
366 WordGtOp -> trivialCode (CMP ULT) y x
367 WordGeOp -> trivialCode (CMP ULE) x y
368 WordEqOp -> trivialCode (CMP EQQ) x y
369 WordNeOp -> int_NE_code x y
370 WordLtOp -> trivialCode (CMP ULT) x y
371 WordLeOp -> trivialCode (CMP ULE) x y
373 AddrGtOp -> trivialCode (CMP ULT) y x
374 AddrGeOp -> trivialCode (CMP ULE) y x
375 AddrEqOp -> trivialCode (CMP EQQ) x y
376 AddrNeOp -> int_NE_code x y
377 AddrLtOp -> trivialCode (CMP ULT) x y
378 AddrLeOp -> trivialCode (CMP ULE) x y
380 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
381 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
382 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
383 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
384 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
385 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
387 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
388 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
389 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
390 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
391 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
392 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
394 IntAddOp -> trivialCode (ADD Q False) x y
395 IntSubOp -> trivialCode (SUB Q False) x y
396 IntMulOp -> trivialCode (MUL Q False) x y
397 IntQuotOp -> trivialCode (DIV Q False) x y
398 IntRemOp -> trivialCode (REM Q False) x y
400 WordQuotOp -> trivialCode (DIV Q True) x y
401 WordRemOp -> trivialCode (REM Q True) x y
403 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
404 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
405 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
406 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
408 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
409 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
410 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
411 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
413 AndOp -> trivialCode AND x y
414 OrOp -> trivialCode OR x y
415 XorOp -> trivialCode XOR x y
416 SllOp -> trivialCode SLL x y
417 SrlOp -> trivialCode SRL x y
419 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
420 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
421 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
423 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
424 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
426 {- ------------------------------------------------------------
427 Some bizarre special code for getting condition codes into
428 registers. Integer non-equality is a test for equality
429 followed by an XOR with 1. (Integer comparisons always set
430 the result register to 0 or 1.) Floating point comparisons of
431 any kind leave the result in a floating point register, so we
432 need to wrangle an integer register out of things.
434 int_NE_code :: StixTree -> StixTree -> NatM Register
437 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
438 getNewRegNCG IntRep `thenNat` \ tmp ->
440 code = registerCode register tmp
441 src = registerName register tmp
442 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
444 returnNat (Any IntRep code__2)
446 {- ------------------------------------------------------------
447 Comments for int_NE_code also apply to cmpF_code
450 :: (Reg -> Reg -> Reg -> Instr)
452 -> StixTree -> StixTree
455 cmpF_code instr cond x y
456 = trivialFCode pr instr x y `thenNat` \ register ->
457 getNewRegNCG DoubleRep `thenNat` \ tmp ->
458 getNatLabelNCG `thenNat` \ lbl ->
460 code = registerCode register tmp
461 result = registerName register tmp
463 code__2 dst = code . mkSeqInstrs [
464 OR zeroh (RIImm (ImmInt 1)) dst,
465 BF cond result (ImmCLbl lbl),
466 OR zeroh (RIReg zeroh) dst,
469 returnNat (Any IntRep code__2)
471 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
472 ------------------------------------------------------------
474 getRegister (StInd pk mem)
475 = getAmode mem `thenNat` \ amode ->
477 code = amodeCode amode
478 src = amodeAddr amode
479 size = primRepToSize pk
480 code__2 dst = code . mkSeqInstr (LD size dst src)
482 returnNat (Any pk code__2)
484 getRegister (StInt i)
487 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
489 returnNat (Any IntRep code)
492 code dst = mkSeqInstr (LDI Q dst src)
494 returnNat (Any IntRep code)
496 src = ImmInt (fromInteger i)
501 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
503 returnNat (Any PtrRep code)
506 imm__2 = case imm of Just x -> x
508 #endif {- alpha_TARGET_ARCH -}
509 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
512 getRegister (StFloat f)
513 = getNatLabelNCG `thenNat` \ lbl ->
514 let code dst = toOL [
519 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
522 returnNat (Any FloatRep code)
525 getRegister (StDouble d)
528 = let code dst = unitOL (GLDZ dst)
529 in returnNat (Any DoubleRep code)
532 = let code dst = unitOL (GLD1 dst)
533 in returnNat (Any DoubleRep code)
536 = getNatLabelNCG `thenNat` \ lbl ->
537 let code dst = toOL [
540 DATA DF [ImmDouble d],
542 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
545 returnNat (Any DoubleRep code)
547 -- Calculate the offset for (i+1) words above the _initial_
548 -- %esp value by first determining the current offset of it.
549 getRegister (StScratchWord i)
551 = getDeltaNat `thenNat` \ current_stack_offset ->
552 let j = i+1 - (current_stack_offset `div` 4)
554 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
556 returnNat (Any PtrRep code)
558 getRegister (StPrim primop [x]) -- unary PrimOps
560 IntNegOp -> trivialUCode (NEGI L) x
561 NotOp -> trivialUCode (NOT L) x
563 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
564 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
566 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
567 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
569 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
570 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
572 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
573 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
575 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
576 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
578 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
579 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
581 OrdOp -> coerceIntCode IntRep x
584 Float2IntOp -> coerceFP2Int x
585 Int2FloatOp -> coerceInt2FP FloatRep x
586 Double2IntOp -> coerceFP2Int x
587 Int2DoubleOp -> coerceInt2FP DoubleRep x
590 getRegister (StCall fn cCallConv DoubleRep [x])
594 FloatExpOp -> (True, SLIT("exp"))
595 FloatLogOp -> (True, SLIT("log"))
597 FloatAsinOp -> (True, SLIT("asin"))
598 FloatAcosOp -> (True, SLIT("acos"))
599 FloatAtanOp -> (True, SLIT("atan"))
601 FloatSinhOp -> (True, SLIT("sinh"))
602 FloatCoshOp -> (True, SLIT("cosh"))
603 FloatTanhOp -> (True, SLIT("tanh"))
605 DoubleExpOp -> (False, SLIT("exp"))
606 DoubleLogOp -> (False, SLIT("log"))
608 DoubleAsinOp -> (False, SLIT("asin"))
609 DoubleAcosOp -> (False, SLIT("acos"))
610 DoubleAtanOp -> (False, SLIT("atan"))
612 DoubleSinhOp -> (False, SLIT("sinh"))
613 DoubleCoshOp -> (False, SLIT("cosh"))
614 DoubleTanhOp -> (False, SLIT("tanh"))
617 -> pprPanic "getRegister(x86,unary primop)"
618 (pprStixTree (StPrim primop [x]))
620 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
622 CharGtOp -> condIntReg GTT x y
623 CharGeOp -> condIntReg GE x y
624 CharEqOp -> condIntReg EQQ x y
625 CharNeOp -> condIntReg NE x y
626 CharLtOp -> condIntReg LTT x y
627 CharLeOp -> condIntReg LE x y
629 IntGtOp -> condIntReg GTT x y
630 IntGeOp -> condIntReg GE x y
631 IntEqOp -> condIntReg EQQ x y
632 IntNeOp -> condIntReg NE x y
633 IntLtOp -> condIntReg LTT x y
634 IntLeOp -> condIntReg LE x y
636 WordGtOp -> condIntReg GU x y
637 WordGeOp -> condIntReg GEU x y
638 WordEqOp -> condIntReg EQQ x y
639 WordNeOp -> condIntReg NE x y
640 WordLtOp -> condIntReg LU x y
641 WordLeOp -> condIntReg LEU x y
643 AddrGtOp -> condIntReg GU x y
644 AddrGeOp -> condIntReg GEU x y
645 AddrEqOp -> condIntReg EQQ x y
646 AddrNeOp -> condIntReg NE x y
647 AddrLtOp -> condIntReg LU x y
648 AddrLeOp -> condIntReg LEU x y
650 FloatGtOp -> condFltReg GTT x y
651 FloatGeOp -> condFltReg GE x y
652 FloatEqOp -> condFltReg EQQ x y
653 FloatNeOp -> condFltReg NE x y
654 FloatLtOp -> condFltReg LTT x y
655 FloatLeOp -> condFltReg LE x y
657 DoubleGtOp -> condFltReg GTT x y
658 DoubleGeOp -> condFltReg GE x y
659 DoubleEqOp -> condFltReg EQQ x y
660 DoubleNeOp -> condFltReg NE x y
661 DoubleLtOp -> condFltReg LTT x y
662 DoubleLeOp -> condFltReg LE x y
664 IntAddOp -> add_code L x y
665 IntSubOp -> sub_code L x y
666 IntQuotOp -> quot_code L x y True{-division-}
667 IntRemOp -> quot_code L x y False{-remainder-}
668 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
670 FloatAddOp -> trivialFCode FloatRep GADD x y
671 FloatSubOp -> trivialFCode FloatRep GSUB x y
672 FloatMulOp -> trivialFCode FloatRep GMUL x y
673 FloatDivOp -> trivialFCode FloatRep GDIV x y
675 DoubleAddOp -> trivialFCode DoubleRep GADD x y
676 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
677 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
678 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
680 AndOp -> let op = AND L in trivialCode op (Just op) x y
681 OrOp -> let op = OR L in trivialCode op (Just op) x y
682 XorOp -> let op = XOR L in trivialCode op (Just op) x y
684 {- Shift ops on x86s have constraints on their source, it
685 either has to be Imm, CL or 1
686 => trivialCode's is not restrictive enough (sigh.)
689 SllOp -> shift_code (SHL L) x y {-False-}
690 SrlOp -> shift_code (SHR L) x y {-False-}
691 ISllOp -> shift_code (SHL L) x y {-False-}
692 ISraOp -> shift_code (SAR L) x y {-False-}
693 ISrlOp -> shift_code (SHR L) x y {-False-}
695 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
696 [promote x, promote y])
697 where promote x = StPrim Float2DoubleOp [x]
698 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
701 -> pprPanic "getRegister(x86,dyadic primop)"
702 (pprStixTree (StPrim primop [x, y]))
706 shift_code :: (Imm -> Operand -> Instr)
711 {- Case1: shift length as immediate -}
712 -- Code is the same as the first eq. for trivialCode -- sigh.
713 shift_code instr x y{-amount-}
715 = getRegister x `thenNat` \ regx ->
718 then registerCodeA regx dst `bind` \ code_x ->
720 instr imm__2 (OpReg dst)
721 else registerCodeF regx `bind` \ code_x ->
722 registerNameF regx `bind` \ r_x ->
724 MOV L (OpReg r_x) (OpReg dst) `snocOL`
725 instr imm__2 (OpReg dst)
727 returnNat (Any IntRep mkcode)
730 imm__2 = case imm of Just x -> x
732 {- Case2: shift length is complex (non-immediate) -}
733 -- Since ECX is always used as a spill temporary, we can't
734 -- use it here to do non-immediate shifts. No big deal --
735 -- they are only very rare, and we can use an equivalent
736 -- test-and-jump sequence which doesn't use ECX.
737 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
738 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
739 shift_code instr x y{-amount-}
740 = getRegister x `thenNat` \ register1 ->
741 getRegister y `thenNat` \ register2 ->
742 getNatLabelNCG `thenNat` \ lbl_test3 ->
743 getNatLabelNCG `thenNat` \ lbl_test2 ->
744 getNatLabelNCG `thenNat` \ lbl_test1 ->
745 getNatLabelNCG `thenNat` \ lbl_test0 ->
746 getNatLabelNCG `thenNat` \ lbl_after ->
747 getNewRegNCG IntRep `thenNat` \ tmp ->
749 = let src_val = registerName register1 dst
750 code_val = registerCode register1 dst
751 src_amt = registerName register2 tmp
752 code_amt = registerCode register2 tmp
757 MOV L (OpReg src_amt) r_tmp `appOL`
759 MOV L (OpReg src_val) r_dst `appOL`
761 COMMENT (_PK_ "begin shift sequence"),
762 MOV L (OpReg src_val) r_dst,
763 MOV L (OpReg src_amt) r_tmp,
765 BT L (ImmInt 4) r_tmp,
767 instr (ImmInt 16) r_dst,
770 BT L (ImmInt 3) r_tmp,
772 instr (ImmInt 8) r_dst,
775 BT L (ImmInt 2) r_tmp,
777 instr (ImmInt 4) r_dst,
780 BT L (ImmInt 1) r_tmp,
782 instr (ImmInt 2) r_dst,
785 BT L (ImmInt 0) r_tmp,
787 instr (ImmInt 1) r_dst,
790 COMMENT (_PK_ "end shift sequence")
793 returnNat (Any IntRep code__2)
796 add_code :: Size -> StixTree -> StixTree -> NatM Register
798 add_code sz x (StInt y)
799 = getRegister x `thenNat` \ register ->
800 getNewRegNCG IntRep `thenNat` \ tmp ->
802 code = registerCode register tmp
803 src1 = registerName register tmp
804 src2 = ImmInt (fromInteger y)
807 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
810 returnNat (Any IntRep code__2)
812 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
815 sub_code :: Size -> StixTree -> StixTree -> NatM Register
817 sub_code sz x (StInt y)
818 = getRegister x `thenNat` \ register ->
819 getNewRegNCG IntRep `thenNat` \ tmp ->
821 code = registerCode register tmp
822 src1 = registerName register tmp
823 src2 = ImmInt (-(fromInteger y))
826 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
829 returnNat (Any IntRep code__2)
831 sub_code sz x y = trivialCode (SUB sz) Nothing x y
836 -> StixTree -> StixTree
837 -> Bool -- True => division, False => remainder operation
840 -- x must go into eax, edx must be a sign-extension of eax, and y
841 -- should go in some other register (or memory), so that we get
842 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
843 -- to put y on the C stack, since that avoids tying up yet another
844 -- precious register.
846 quot_code sz x y is_division
847 = getRegister x `thenNat` \ register1 ->
848 getRegister y `thenNat` \ register2 ->
849 getNewRegNCG IntRep `thenNat` \ tmp ->
850 getDeltaNat `thenNat` \ delta ->
852 code1 = registerCode register1 tmp
853 src1 = registerName register1 tmp
854 code2 = registerCode register2 tmp
855 src2 = registerName register2 tmp
856 code__2 = code2 `snocOL` -- src2 := y
857 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
858 DELTA (delta-4) `appOL`
859 code1 `snocOL` -- src1 := x
860 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
862 IDIV sz (OpAddr (spRel 0)) `snocOL`
863 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
866 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
867 -----------------------
869 getRegister (StInd pk mem)
870 = getAmode mem `thenNat` \ amode ->
872 code = amodeCode amode
873 src = amodeAddr amode
874 size = primRepToSize pk
875 code__2 dst = code `snocOL`
876 if pk == DoubleRep || pk == FloatRep
877 then GLD size src dst
879 L -> MOV L (OpAddr src) (OpReg dst)
880 B -> MOVZxL B (OpAddr src) (OpReg dst)
882 returnNat (Any pk code__2)
884 getRegister (StInt i)
886 src = ImmInt (fromInteger i)
889 = unitOL (XOR L (OpReg dst) (OpReg dst))
891 = unitOL (MOV L (OpImm src) (OpReg dst))
893 returnNat (Any IntRep code)
897 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
899 returnNat (Any PtrRep code)
901 = pprPanic "getRegister(x86)" (pprStixTree leaf)
904 imm__2 = case imm of Just x -> x
906 #endif {- i386_TARGET_ARCH -}
907 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
908 #if sparc_TARGET_ARCH
910 getRegister (StFloat d)
911 = getNatLabelNCG `thenNat` \ lbl ->
912 getNewRegNCG PtrRep `thenNat` \ tmp ->
913 let code dst = toOL [
918 SETHI (HI (ImmCLbl lbl)) tmp,
919 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
921 returnNat (Any FloatRep code)
923 getRegister (StDouble d)
924 = getNatLabelNCG `thenNat` \ lbl ->
925 getNewRegNCG PtrRep `thenNat` \ tmp ->
926 let code dst = toOL [
929 DATA DF [ImmDouble d],
931 SETHI (HI (ImmCLbl lbl)) tmp,
932 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
934 returnNat (Any DoubleRep code)
936 -- The 6-word scratch area is immediately below the frame pointer.
937 -- Below that is the spill area.
938 getRegister (StScratchWord i)
941 code dst = unitOL (fpRelEA j dst)
943 returnNat (Any PtrRep code)
946 getRegister (StPrim primop [x]) -- unary PrimOps
948 IntNegOp -> trivialUCode (SUB False False g0) x
949 NotOp -> trivialUCode (XNOR False g0) x
951 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
952 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
954 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
956 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
957 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
959 OrdOp -> coerceIntCode IntRep x
962 Float2IntOp -> coerceFP2Int x
963 Int2FloatOp -> coerceInt2FP FloatRep x
964 Double2IntOp -> coerceFP2Int x
965 Int2DoubleOp -> coerceInt2FP DoubleRep x
969 fixed_x = if is_float_op -- promote to double
970 then StPrim Float2DoubleOp [x]
973 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
977 FloatExpOp -> (True, SLIT("exp"))
978 FloatLogOp -> (True, SLIT("log"))
979 FloatSqrtOp -> (True, SLIT("sqrt"))
981 FloatSinOp -> (True, SLIT("sin"))
982 FloatCosOp -> (True, SLIT("cos"))
983 FloatTanOp -> (True, SLIT("tan"))
985 FloatAsinOp -> (True, SLIT("asin"))
986 FloatAcosOp -> (True, SLIT("acos"))
987 FloatAtanOp -> (True, SLIT("atan"))
989 FloatSinhOp -> (True, SLIT("sinh"))
990 FloatCoshOp -> (True, SLIT("cosh"))
991 FloatTanhOp -> (True, SLIT("tanh"))
993 DoubleExpOp -> (False, SLIT("exp"))
994 DoubleLogOp -> (False, SLIT("log"))
995 DoubleSqrtOp -> (False, SLIT("sqrt"))
997 DoubleSinOp -> (False, SLIT("sin"))
998 DoubleCosOp -> (False, SLIT("cos"))
999 DoubleTanOp -> (False, SLIT("tan"))
1001 DoubleAsinOp -> (False, SLIT("asin"))
1002 DoubleAcosOp -> (False, SLIT("acos"))
1003 DoubleAtanOp -> (False, SLIT("atan"))
1005 DoubleSinhOp -> (False, SLIT("sinh"))
1006 DoubleCoshOp -> (False, SLIT("cosh"))
1007 DoubleTanhOp -> (False, SLIT("tanh"))
1010 -> pprPanic "getRegister(sparc,monadicprimop)"
1011 (pprStixTree (StPrim primop [x]))
1013 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1015 CharGtOp -> condIntReg GTT x y
1016 CharGeOp -> condIntReg GE x y
1017 CharEqOp -> condIntReg EQQ x y
1018 CharNeOp -> condIntReg NE x y
1019 CharLtOp -> condIntReg LTT x y
1020 CharLeOp -> condIntReg LE x y
1022 IntGtOp -> condIntReg GTT x y
1023 IntGeOp -> condIntReg GE x y
1024 IntEqOp -> condIntReg EQQ x y
1025 IntNeOp -> condIntReg NE x y
1026 IntLtOp -> condIntReg LTT x y
1027 IntLeOp -> condIntReg LE x y
1029 WordGtOp -> condIntReg GU x y
1030 WordGeOp -> condIntReg GEU x y
1031 WordEqOp -> condIntReg EQQ x y
1032 WordNeOp -> condIntReg NE x y
1033 WordLtOp -> condIntReg LU x y
1034 WordLeOp -> condIntReg LEU x y
1036 AddrGtOp -> condIntReg GU x y
1037 AddrGeOp -> condIntReg GEU x y
1038 AddrEqOp -> condIntReg EQQ x y
1039 AddrNeOp -> condIntReg NE x y
1040 AddrLtOp -> condIntReg LU x y
1041 AddrLeOp -> condIntReg LEU x y
1043 FloatGtOp -> condFltReg GTT x y
1044 FloatGeOp -> condFltReg GE x y
1045 FloatEqOp -> condFltReg EQQ x y
1046 FloatNeOp -> condFltReg NE x y
1047 FloatLtOp -> condFltReg LTT x y
1048 FloatLeOp -> condFltReg LE x y
1050 DoubleGtOp -> condFltReg GTT x y
1051 DoubleGeOp -> condFltReg GE x y
1052 DoubleEqOp -> condFltReg EQQ x y
1053 DoubleNeOp -> condFltReg NE x y
1054 DoubleLtOp -> condFltReg LTT x y
1055 DoubleLeOp -> condFltReg LE x y
1057 IntAddOp -> trivialCode (ADD False False) x y
1058 IntSubOp -> trivialCode (SUB False False) x y
1060 -- ToDo: teach about V8+ SPARC mul/div instructions
1061 IntMulOp -> imul_div SLIT(".umul") x y
1062 IntQuotOp -> imul_div SLIT(".div") x y
1063 IntRemOp -> imul_div SLIT(".rem") x y
1065 FloatAddOp -> trivialFCode FloatRep FADD x y
1066 FloatSubOp -> trivialFCode FloatRep FSUB x y
1067 FloatMulOp -> trivialFCode FloatRep FMUL x y
1068 FloatDivOp -> trivialFCode FloatRep FDIV x y
1070 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1071 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1072 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1073 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1075 AndOp -> trivialCode (AND False) x y
1076 OrOp -> trivialCode (OR False) x y
1077 XorOp -> trivialCode (XOR False) x y
1078 SllOp -> trivialCode SLL x y
1079 SrlOp -> trivialCode SRL x y
1081 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1082 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1083 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1085 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1086 [promote x, promote y])
1087 where promote x = StPrim Float2DoubleOp [x]
1088 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1092 -> pprPanic "getRegister(sparc,dyadic primop)"
1093 (pprStixTree (StPrim primop [x, y]))
1096 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1098 getRegister (StInd pk mem)
1099 = getAmode mem `thenNat` \ amode ->
1101 code = amodeCode amode
1102 src = amodeAddr amode
1103 size = primRepToSize pk
1104 code__2 dst = code `snocOL` LD size src dst
1106 returnNat (Any pk code__2)
1108 getRegister (StInt i)
1111 src = ImmInt (fromInteger i)
1112 code dst = unitOL (OR False g0 (RIImm src) dst)
1114 returnNat (Any IntRep code)
1120 SETHI (HI imm__2) dst,
1121 OR False dst (RIImm (LO imm__2)) dst]
1123 returnNat (Any PtrRep code)
1125 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1128 imm__2 = case imm of Just x -> x
1130 #endif {- sparc_TARGET_ARCH -}
1133 %************************************************************************
1135 \subsection{The @Amode@ type}
1137 %************************************************************************
1139 @Amode@s: Memory addressing modes passed up the tree.
1141 data Amode = Amode MachRegsAddr InstrBlock
1143 amodeAddr (Amode addr _) = addr
1144 amodeCode (Amode _ code) = code
1147 Now, given a tree (the argument to an StInd) that references memory,
1148 produce a suitable addressing mode.
1150 A Rule of the Game (tm) for Amodes: use of the addr bit must
1151 immediately follow use of the code part, since the code part puts
1152 values in registers which the addr then refers to. So you can't put
1153 anything in between, lest it overwrite some of those registers. If
1154 you need to do some other computation between the code part and use of
1155 the addr bit, first store the effective address from the amode in a
1156 temporary, then do the other computation, and then use the temporary:
1160 ... other computation ...
1164 getAmode :: StixTree -> NatM Amode
1166 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1168 #if alpha_TARGET_ARCH
1170 getAmode (StPrim IntSubOp [x, StInt i])
1171 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1172 getRegister x `thenNat` \ register ->
1174 code = registerCode register tmp
1175 reg = registerName register tmp
1176 off = ImmInt (-(fromInteger i))
1178 returnNat (Amode (AddrRegImm reg off) code)
1180 getAmode (StPrim IntAddOp [x, StInt i])
1181 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1182 getRegister x `thenNat` \ register ->
1184 code = registerCode register tmp
1185 reg = registerName register tmp
1186 off = ImmInt (fromInteger i)
1188 returnNat (Amode (AddrRegImm reg off) code)
1192 = returnNat (Amode (AddrImm imm__2) id)
1195 imm__2 = case imm of Just x -> x
1198 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1199 getRegister other `thenNat` \ register ->
1201 code = registerCode register tmp
1202 reg = registerName register tmp
1204 returnNat (Amode (AddrReg reg) code)
1206 #endif {- alpha_TARGET_ARCH -}
1207 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1208 #if i386_TARGET_ARCH
1210 getAmode (StPrim IntSubOp [x, StInt i])
1211 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1212 getRegister x `thenNat` \ register ->
1214 code = registerCode register tmp
1215 reg = registerName register tmp
1216 off = ImmInt (-(fromInteger i))
1218 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1220 getAmode (StPrim IntAddOp [x, StInt i])
1222 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1225 imm__2 = case imm of Just x -> x
1227 getAmode (StPrim IntAddOp [x, StInt i])
1228 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1229 getRegister x `thenNat` \ register ->
1231 code = registerCode register tmp
1232 reg = registerName register tmp
1233 off = ImmInt (fromInteger i)
1235 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1237 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1238 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1239 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1240 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1241 getRegister x `thenNat` \ register1 ->
1242 getRegister y `thenNat` \ register2 ->
1244 code1 = registerCode register1 tmp1
1245 reg1 = registerName register1 tmp1
1246 code2 = registerCode register2 tmp2
1247 reg2 = registerName register2 tmp2
1248 code__2 = code1 `appOL` code2
1249 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1251 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1256 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1259 imm__2 = case imm of Just x -> x
1262 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1263 getRegister other `thenNat` \ register ->
1265 code = registerCode register tmp
1266 reg = registerName register tmp
1268 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1270 #endif {- i386_TARGET_ARCH -}
1271 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1272 #if sparc_TARGET_ARCH
1274 getAmode (StPrim IntSubOp [x, StInt i])
1276 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1277 getRegister x `thenNat` \ register ->
1279 code = registerCode register tmp
1280 reg = registerName register tmp
1281 off = ImmInt (-(fromInteger i))
1283 returnNat (Amode (AddrRegImm reg off) code)
1286 getAmode (StPrim IntAddOp [x, StInt i])
1288 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1289 getRegister x `thenNat` \ register ->
1291 code = registerCode register tmp
1292 reg = registerName register tmp
1293 off = ImmInt (fromInteger i)
1295 returnNat (Amode (AddrRegImm reg off) code)
1297 getAmode (StPrim IntAddOp [x, y])
1298 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1299 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1300 getRegister x `thenNat` \ register1 ->
1301 getRegister y `thenNat` \ register2 ->
1303 code1 = registerCode register1 tmp1
1304 reg1 = registerName register1 tmp1
1305 code2 = registerCode register2 tmp2
1306 reg2 = registerName register2 tmp2
1307 code__2 = code1 `appOL` code2
1309 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1313 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1315 code = unitOL (SETHI (HI imm__2) tmp)
1317 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1320 imm__2 = case imm of Just x -> x
1323 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1324 getRegister other `thenNat` \ register ->
1326 code = registerCode register tmp
1327 reg = registerName register tmp
1330 returnNat (Amode (AddrRegImm reg off) code)
1332 #endif {- sparc_TARGET_ARCH -}
1335 %************************************************************************
1337 \subsection{The @CondCode@ type}
1339 %************************************************************************
1341 Condition codes passed up the tree.
1343 data CondCode = CondCode Bool Cond InstrBlock
1345 condName (CondCode _ cond _) = cond
1346 condFloat (CondCode is_float _ _) = is_float
1347 condCode (CondCode _ _ code) = code
1350 Set up a condition code for a conditional branch.
1353 getCondCode :: StixTree -> NatM CondCode
1355 #if alpha_TARGET_ARCH
1356 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1357 #endif {- alpha_TARGET_ARCH -}
1358 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1360 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1361 -- yes, they really do seem to want exactly the same!
1363 getCondCode (StPrim primop [x, y])
1365 CharGtOp -> condIntCode GTT x y
1366 CharGeOp -> condIntCode GE x y
1367 CharEqOp -> condIntCode EQQ x y
1368 CharNeOp -> condIntCode NE x y
1369 CharLtOp -> condIntCode LTT x y
1370 CharLeOp -> condIntCode LE x y
1372 IntGtOp -> condIntCode GTT x y
1373 IntGeOp -> condIntCode GE x y
1374 IntEqOp -> condIntCode EQQ x y
1375 IntNeOp -> condIntCode NE x y
1376 IntLtOp -> condIntCode LTT x y
1377 IntLeOp -> condIntCode LE x y
1379 WordGtOp -> condIntCode GU x y
1380 WordGeOp -> condIntCode GEU x y
1381 WordEqOp -> condIntCode EQQ x y
1382 WordNeOp -> condIntCode NE x y
1383 WordLtOp -> condIntCode LU x y
1384 WordLeOp -> condIntCode LEU x y
1386 AddrGtOp -> condIntCode GU x y
1387 AddrGeOp -> condIntCode GEU x y
1388 AddrEqOp -> condIntCode EQQ x y
1389 AddrNeOp -> condIntCode NE x y
1390 AddrLtOp -> condIntCode LU x y
1391 AddrLeOp -> condIntCode LEU x y
1393 FloatGtOp -> condFltCode GTT x y
1394 FloatGeOp -> condFltCode GE x y
1395 FloatEqOp -> condFltCode EQQ x y
1396 FloatNeOp -> condFltCode NE x y
1397 FloatLtOp -> condFltCode LTT x y
1398 FloatLeOp -> condFltCode LE x y
1400 DoubleGtOp -> condFltCode GTT x y
1401 DoubleGeOp -> condFltCode GE x y
1402 DoubleEqOp -> condFltCode EQQ x y
1403 DoubleNeOp -> condFltCode NE x y
1404 DoubleLtOp -> condFltCode LTT x y
1405 DoubleLeOp -> condFltCode LE x y
1407 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1412 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1413 passed back up the tree.
1416 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1418 #if alpha_TARGET_ARCH
1419 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1420 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1421 #endif {- alpha_TARGET_ARCH -}
1423 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1424 #if i386_TARGET_ARCH
1426 -- memory vs immediate
1427 condIntCode cond (StInd pk x) y
1429 = getAmode x `thenNat` \ amode ->
1431 code1 = amodeCode amode
1432 x__2 = amodeAddr amode
1433 sz = primRepToSize pk
1434 code__2 = code1 `snocOL`
1435 CMP sz (OpImm imm__2) (OpAddr x__2)
1437 returnNat (CondCode False cond code__2)
1440 imm__2 = case imm of Just x -> x
1443 condIntCode cond x (StInt 0)
1444 = getRegister x `thenNat` \ register1 ->
1445 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1447 code1 = registerCode register1 tmp1
1448 src1 = registerName register1 tmp1
1449 code__2 = code1 `snocOL`
1450 TEST L (OpReg src1) (OpReg src1)
1452 returnNat (CondCode False cond code__2)
1454 -- anything vs immediate
1455 condIntCode cond x y
1457 = getRegister x `thenNat` \ register1 ->
1458 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1460 code1 = registerCode register1 tmp1
1461 src1 = registerName register1 tmp1
1462 code__2 = code1 `snocOL`
1463 CMP L (OpImm imm__2) (OpReg src1)
1465 returnNat (CondCode False cond code__2)
1468 imm__2 = case imm of Just x -> x
1470 -- memory vs anything
1471 condIntCode cond (StInd pk x) y
1472 = getAmode x `thenNat` \ amode_x ->
1473 getRegister y `thenNat` \ reg_y ->
1474 getNewRegNCG IntRep `thenNat` \ tmp ->
1476 c_x = amodeCode amode_x
1477 am_x = amodeAddr amode_x
1478 c_y = registerCode reg_y tmp
1479 r_y = registerName reg_y tmp
1480 sz = primRepToSize pk
1482 -- optimisation: if there's no code for x, just an amode,
1483 -- use whatever reg y winds up in. Assumes that c_y doesn't
1484 -- clobber any regs in the amode am_x, which I'm not sure is
1485 -- justified. The otherwise clause makes the same assumption.
1486 code__2 | isNilOL c_x
1488 CMP sz (OpReg r_y) (OpAddr am_x)
1492 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1494 CMP sz (OpReg tmp) (OpAddr am_x)
1496 returnNat (CondCode False cond code__2)
1498 -- anything vs memory
1500 condIntCode cond y (StInd pk x)
1501 = getAmode x `thenNat` \ amode_x ->
1502 getRegister y `thenNat` \ reg_y ->
1503 getNewRegNCG IntRep `thenNat` \ tmp ->
1505 c_x = amodeCode amode_x
1506 am_x = amodeAddr amode_x
1507 c_y = registerCode reg_y tmp
1508 r_y = registerName reg_y tmp
1509 sz = primRepToSize pk
1510 -- same optimisation and nagging doubts as previous clause
1511 code__2 | isNilOL c_x
1513 CMP sz (OpAddr am_x) (OpReg r_y)
1517 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1519 CMP sz (OpAddr am_x) (OpReg tmp)
1521 returnNat (CondCode False cond code__2)
1523 -- anything vs anything
1524 condIntCode cond x y
1525 = getRegister x `thenNat` \ register1 ->
1526 getRegister y `thenNat` \ register2 ->
1527 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1528 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1530 code1 = registerCode register1 tmp1
1531 src1 = registerName register1 tmp1
1532 code2 = registerCode register2 tmp2
1533 src2 = registerName register2 tmp2
1534 code__2 = code1 `snocOL`
1535 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1537 CMP L (OpReg src2) (OpReg tmp1)
1539 returnNat (CondCode False cond code__2)
1542 condFltCode cond x y
1543 = getRegister x `thenNat` \ register1 ->
1544 getRegister y `thenNat` \ register2 ->
1545 getNewRegNCG (registerRep register1)
1547 getNewRegNCG (registerRep register2)
1549 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1551 pk1 = registerRep register1
1552 code1 = registerCode register1 tmp1
1553 src1 = registerName register1 tmp1
1555 code2 = registerCode register2 tmp2
1556 src2 = registerName register2 tmp2
1558 code__2 | isAny register1
1559 = code1 `appOL` -- result in tmp1
1561 GCMP (primRepToSize pk1) tmp1 src2
1565 GMOV src1 tmp1 `appOL`
1567 GCMP (primRepToSize pk1) tmp1 src2
1569 {- On the 486, the flags set by FP compare are the unsigned ones!
1570 (This looks like a HACK to me. WDP 96/03)
1572 fix_FP_cond :: Cond -> Cond
1574 fix_FP_cond GE = GEU
1575 fix_FP_cond GTT = GU
1576 fix_FP_cond LTT = LU
1577 fix_FP_cond LE = LEU
1578 fix_FP_cond any = any
1580 returnNat (CondCode True (fix_FP_cond cond) code__2)
1584 #endif {- i386_TARGET_ARCH -}
1585 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1586 #if sparc_TARGET_ARCH
1588 condIntCode cond x (StInt y)
1590 = getRegister x `thenNat` \ register ->
1591 getNewRegNCG IntRep `thenNat` \ tmp ->
1593 code = registerCode register tmp
1594 src1 = registerName register tmp
1595 src2 = ImmInt (fromInteger y)
1596 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1598 returnNat (CondCode False cond code__2)
1600 condIntCode cond x y
1601 = getRegister x `thenNat` \ register1 ->
1602 getRegister y `thenNat` \ register2 ->
1603 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1604 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1606 code1 = registerCode register1 tmp1
1607 src1 = registerName register1 tmp1
1608 code2 = registerCode register2 tmp2
1609 src2 = registerName register2 tmp2
1610 code__2 = code1 `appOL` code2 `snocOL`
1611 SUB False True src1 (RIReg src2) g0
1613 returnNat (CondCode False cond code__2)
1616 condFltCode cond x y
1617 = getRegister x `thenNat` \ register1 ->
1618 getRegister y `thenNat` \ register2 ->
1619 getNewRegNCG (registerRep register1)
1621 getNewRegNCG (registerRep register2)
1623 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1625 promote x = FxTOy F DF x tmp
1627 pk1 = registerRep register1
1628 code1 = registerCode register1 tmp1
1629 src1 = registerName register1 tmp1
1631 pk2 = registerRep register2
1632 code2 = registerCode register2 tmp2
1633 src2 = registerName register2 tmp2
1637 code1 `appOL` code2 `snocOL`
1638 FCMP True (primRepToSize pk1) src1 src2
1639 else if pk1 == FloatRep then
1640 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1641 FCMP True DF tmp src2
1643 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1644 FCMP True DF src1 tmp
1646 returnNat (CondCode True cond code__2)
1648 #endif {- sparc_TARGET_ARCH -}
1651 %************************************************************************
1653 \subsection{Generating assignments}
1655 %************************************************************************
1657 Assignments are really at the heart of the whole code generation
1658 business. Almost all top-level nodes of any real importance are
1659 assignments, which correspond to loads, stores, or register transfers.
1660 If we're really lucky, some of the register transfers will go away,
1661 because we can use the destination register to complete the code
1662 generation for the right hand side. This only fails when the right
1663 hand side is forced into a fixed register (e.g. the result of a call).
1666 assignIntCode, assignFltCode
1667 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1669 #if alpha_TARGET_ARCH
1671 assignIntCode pk (StInd _ dst) src
1672 = getNewRegNCG IntRep `thenNat` \ tmp ->
1673 getAmode dst `thenNat` \ amode ->
1674 getRegister src `thenNat` \ register ->
1676 code1 = amodeCode amode []
1677 dst__2 = amodeAddr amode
1678 code2 = registerCode register tmp []
1679 src__2 = registerName register tmp
1680 sz = primRepToSize pk
1681 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1685 assignIntCode pk dst src
1686 = getRegister dst `thenNat` \ register1 ->
1687 getRegister src `thenNat` \ register2 ->
1689 dst__2 = registerName register1 zeroh
1690 code = registerCode register2 dst__2
1691 src__2 = registerName register2 dst__2
1692 code__2 = if isFixed register2
1693 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1698 #endif {- alpha_TARGET_ARCH -}
1699 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1700 #if i386_TARGET_ARCH
1702 -- Destination of an assignment can only be reg or mem.
1703 -- This is the mem case.
1704 assignIntCode pk (StInd _ dst) src
1705 = getAmode dst `thenNat` \ amode ->
1706 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1707 getNewRegNCG PtrRep `thenNat` \ tmp ->
1709 -- In general, if the address computation for dst may require
1710 -- some insns preceding the addressing mode itself. So there's
1711 -- no guarantee that the code for dst and the code for src won't
1712 -- write the same register. This means either the address or
1713 -- the value needs to be copied into a temporary. We detect the
1714 -- common case where the amode has no code, and elide the copy.
1715 codea = amodeCode amode
1716 dst__a = amodeAddr amode
1718 code | isNilOL codea
1720 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1724 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1726 MOV (primRepToSize pk) opsrc
1727 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1733 -> NatM (InstrBlock,Operand) -- code, operator
1737 = returnNat (nilOL, OpImm imm_op)
1740 imm_op = case imm of Just x -> x
1743 = getRegister op `thenNat` \ register ->
1744 getNewRegNCG (registerRep register)
1746 let code = registerCode register tmp
1747 reg = registerName register tmp
1749 returnNat (code, OpReg reg)
1751 -- Assign; dst is a reg, rhs is mem
1752 assignIntCode pk dst (StInd pks src)
1753 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1754 getAmode src `thenNat` \ amode ->
1755 getRegister dst `thenNat` \ reg_dst ->
1757 c_addr = amodeCode amode
1758 am_addr = amodeAddr amode
1760 c_dst = registerCode reg_dst tmp -- should be empty
1761 r_dst = registerName reg_dst tmp
1762 szs = primRepToSize pks
1763 opc = case szs of L -> MOV L ; B -> MOVZxL B
1765 code | isNilOL c_dst
1767 opc (OpAddr am_addr) (OpReg r_dst)
1769 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1773 -- dst is a reg, but src could be anything
1774 assignIntCode pk dst src
1775 = getRegister dst `thenNat` \ registerd ->
1776 getRegister src `thenNat` \ registers ->
1777 getNewRegNCG IntRep `thenNat` \ tmp ->
1779 r_dst = registerName registerd tmp
1780 c_dst = registerCode registerd tmp -- should be empty
1781 r_src = registerName registers r_dst
1782 c_src = registerCode registers r_dst
1784 code | isNilOL c_dst
1786 MOV L (OpReg r_src) (OpReg r_dst)
1788 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1792 #endif {- i386_TARGET_ARCH -}
1793 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1794 #if sparc_TARGET_ARCH
1796 assignIntCode pk (StInd _ dst) src
1797 = getNewRegNCG IntRep `thenNat` \ tmp ->
1798 getAmode dst `thenNat` \ amode ->
1799 getRegister src `thenNat` \ register ->
1801 code1 = amodeCode amode
1802 dst__2 = amodeAddr amode
1803 code2 = registerCode register tmp
1804 src__2 = registerName register tmp
1805 sz = primRepToSize pk
1806 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1810 assignIntCode pk dst src
1811 = getRegister dst `thenNat` \ register1 ->
1812 getRegister src `thenNat` \ register2 ->
1814 dst__2 = registerName register1 g0
1815 code = registerCode register2 dst__2
1816 src__2 = registerName register2 dst__2
1817 code__2 = if isFixed register2
1818 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1823 #endif {- sparc_TARGET_ARCH -}
1826 % --------------------------------
1827 Floating-point assignments:
1828 % --------------------------------
1830 #if alpha_TARGET_ARCH
1832 assignFltCode pk (StInd _ dst) src
1833 = getNewRegNCG pk `thenNat` \ tmp ->
1834 getAmode dst `thenNat` \ amode ->
1835 getRegister src `thenNat` \ register ->
1837 code1 = amodeCode amode []
1838 dst__2 = amodeAddr amode
1839 code2 = registerCode register tmp []
1840 src__2 = registerName register tmp
1841 sz = primRepToSize pk
1842 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1846 assignFltCode pk dst src
1847 = getRegister dst `thenNat` \ register1 ->
1848 getRegister src `thenNat` \ register2 ->
1850 dst__2 = registerName register1 zeroh
1851 code = registerCode register2 dst__2
1852 src__2 = registerName register2 dst__2
1853 code__2 = if isFixed register2
1854 then code . mkSeqInstr (FMOV src__2 dst__2)
1859 #endif {- alpha_TARGET_ARCH -}
1860 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1861 #if i386_TARGET_ARCH
1864 assignFltCode pk (StInd pk_dst addr) src
1866 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1868 = getRegister src `thenNat` \ reg_src ->
1869 getRegister addr `thenNat` \ reg_addr ->
1870 getNewRegNCG pk `thenNat` \ tmp_src ->
1871 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1872 let r_src = registerName reg_src tmp_src
1873 c_src = registerCode reg_src tmp_src
1874 r_addr = registerName reg_addr tmp_addr
1875 c_addr = registerCode reg_addr tmp_addr
1876 sz = primRepToSize pk
1878 code = c_src `appOL`
1879 -- no need to preserve r_src across the addr computation,
1880 -- since r_src must be a float reg
1881 -- whilst r_addr is an int reg
1884 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1888 -- dst must be a (FP) register
1889 assignFltCode pk dst src
1890 = getRegister dst `thenNat` \ reg_dst ->
1891 getRegister src `thenNat` \ reg_src ->
1892 getNewRegNCG pk `thenNat` \ tmp ->
1894 r_dst = registerName reg_dst tmp
1895 c_dst = registerCode reg_dst tmp -- should be empty
1897 r_src = registerName reg_src r_dst
1898 c_src = registerCode reg_src r_dst
1900 code | isNilOL c_dst
1901 = if isFixed reg_src
1902 then c_src `snocOL` GMOV r_src r_dst
1905 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1911 #endif {- i386_TARGET_ARCH -}
1912 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1913 #if sparc_TARGET_ARCH
1915 assignFltCode pk (StInd _ dst) src
1916 = getNewRegNCG pk `thenNat` \ tmp1 ->
1917 getAmode dst `thenNat` \ amode ->
1918 getRegister src `thenNat` \ register ->
1920 sz = primRepToSize pk
1921 dst__2 = amodeAddr amode
1923 code1 = amodeCode amode
1924 code2 = registerCode register tmp1
1926 src__2 = registerName register tmp1
1927 pk__2 = registerRep register
1928 sz__2 = primRepToSize pk__2
1930 code__2 = code1 `appOL` code2 `appOL`
1932 then unitOL (ST sz src__2 dst__2)
1933 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1937 assignFltCode pk dst src
1938 = getRegister dst `thenNat` \ register1 ->
1939 getRegister src `thenNat` \ register2 ->
1941 pk__2 = registerRep register2
1942 sz__2 = primRepToSize pk__2
1944 getNewRegNCG pk__2 `thenNat` \ tmp ->
1946 sz = primRepToSize pk
1947 dst__2 = registerName register1 g0 -- must be Fixed
1950 reg__2 = if pk /= pk__2 then tmp else dst__2
1952 code = registerCode register2 reg__2
1954 src__2 = registerName register2 reg__2
1958 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1959 else if isFixed register2 then
1960 code `snocOL` FMOV sz src__2 dst__2
1966 #endif {- sparc_TARGET_ARCH -}
1969 %************************************************************************
1971 \subsection{Generating an unconditional branch}
1973 %************************************************************************
1975 We accept two types of targets: an immediate CLabel or a tree that
1976 gets evaluated into a register. Any CLabels which are AsmTemporaries
1977 are assumed to be in the local block of code, close enough for a
1978 branch instruction. Other CLabels are assumed to be far away.
1980 (If applicable) Do not fill the delay slots here; you will confuse the
1984 genJump :: StixTree{-the branch target-} -> NatM InstrBlock
1986 #if alpha_TARGET_ARCH
1988 genJump (StCLbl lbl)
1989 | isAsmTemp lbl = returnInstr (BR target)
1990 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1992 target = ImmCLbl lbl
1995 = getRegister tree `thenNat` \ register ->
1996 getNewRegNCG PtrRep `thenNat` \ tmp ->
1998 dst = registerName register pv
1999 code = registerCode register pv
2000 target = registerName register pv
2002 if isFixed register then
2003 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2005 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2007 #endif {- alpha_TARGET_ARCH -}
2008 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2009 #if i386_TARGET_ARCH
2011 genJump (StInd pk mem)
2012 = getAmode mem `thenNat` \ amode ->
2014 code = amodeCode amode
2015 target = amodeAddr amode
2017 returnNat (code `snocOL` JMP (OpAddr target))
2021 = returnNat (unitOL (JMP (OpImm target)))
2024 = getRegister tree `thenNat` \ register ->
2025 getNewRegNCG PtrRep `thenNat` \ tmp ->
2027 code = registerCode register tmp
2028 target = registerName register tmp
2030 returnNat (code `snocOL` JMP (OpReg target))
2033 target = case imm of Just x -> x
2035 #endif {- i386_TARGET_ARCH -}
2036 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2037 #if sparc_TARGET_ARCH
2039 genJump (StCLbl lbl)
2040 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2041 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2043 target = ImmCLbl lbl
2046 = getRegister tree `thenNat` \ register ->
2047 getNewRegNCG PtrRep `thenNat` \ tmp ->
2049 code = registerCode register tmp
2050 target = registerName register tmp
2052 returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
2054 #endif {- sparc_TARGET_ARCH -}
2057 %************************************************************************
2059 \subsection{Conditional jumps}
2061 %************************************************************************
2063 Conditional jumps are always to local labels, so we can use branch
2064 instructions. We peek at the arguments to decide what kind of
2067 ALPHA: For comparisons with 0, we're laughing, because we can just do
2068 the desired conditional branch.
2070 I386: First, we have to ensure that the condition
2071 codes are set according to the supplied comparison operation.
2073 SPARC: First, we have to ensure that the condition codes are set
2074 according to the supplied comparison operation. We generate slightly
2075 different code for floating point comparisons, because a floating
2076 point operation cannot directly precede a @BF@. We assume the worst
2077 and fill that slot with a @NOP@.
2079 SPARC: Do not fill the delay slots here; you will confuse the register
2084 :: CLabel -- the branch target
2085 -> StixTree -- the condition on which to branch
2088 #if alpha_TARGET_ARCH
2090 genCondJump lbl (StPrim op [x, StInt 0])
2091 = getRegister x `thenNat` \ register ->
2092 getNewRegNCG (registerRep register)
2095 code = registerCode register tmp
2096 value = registerName register tmp
2097 pk = registerRep register
2098 target = ImmCLbl lbl
2100 returnSeq code [BI (cmpOp op) value target]
2102 cmpOp CharGtOp = GTT
2104 cmpOp CharEqOp = EQQ
2106 cmpOp CharLtOp = LTT
2115 cmpOp WordGeOp = ALWAYS
2116 cmpOp WordEqOp = EQQ
2118 cmpOp WordLtOp = NEVER
2119 cmpOp WordLeOp = EQQ
2121 cmpOp AddrGeOp = ALWAYS
2122 cmpOp AddrEqOp = EQQ
2124 cmpOp AddrLtOp = NEVER
2125 cmpOp AddrLeOp = EQQ
2127 genCondJump lbl (StPrim op [x, StDouble 0.0])
2128 = getRegister x `thenNat` \ register ->
2129 getNewRegNCG (registerRep register)
2132 code = registerCode register tmp
2133 value = registerName register tmp
2134 pk = registerRep register
2135 target = ImmCLbl lbl
2137 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2139 cmpOp FloatGtOp = GTT
2140 cmpOp FloatGeOp = GE
2141 cmpOp FloatEqOp = EQQ
2142 cmpOp FloatNeOp = NE
2143 cmpOp FloatLtOp = LTT
2144 cmpOp FloatLeOp = LE
2145 cmpOp DoubleGtOp = GTT
2146 cmpOp DoubleGeOp = GE
2147 cmpOp DoubleEqOp = EQQ
2148 cmpOp DoubleNeOp = NE
2149 cmpOp DoubleLtOp = LTT
2150 cmpOp DoubleLeOp = LE
2152 genCondJump lbl (StPrim op [x, y])
2154 = trivialFCode pr instr x y `thenNat` \ register ->
2155 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2157 code = registerCode register tmp
2158 result = registerName register tmp
2159 target = ImmCLbl lbl
2161 returnNat (code . mkSeqInstr (BF cond result target))
2163 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2165 fltCmpOp op = case op of
2179 (instr, cond) = case op of
2180 FloatGtOp -> (FCMP TF LE, EQQ)
2181 FloatGeOp -> (FCMP TF LTT, EQQ)
2182 FloatEqOp -> (FCMP TF EQQ, NE)
2183 FloatNeOp -> (FCMP TF EQQ, EQQ)
2184 FloatLtOp -> (FCMP TF LTT, NE)
2185 FloatLeOp -> (FCMP TF LE, NE)
2186 DoubleGtOp -> (FCMP TF LE, EQQ)
2187 DoubleGeOp -> (FCMP TF LTT, EQQ)
2188 DoubleEqOp -> (FCMP TF EQQ, NE)
2189 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2190 DoubleLtOp -> (FCMP TF LTT, NE)
2191 DoubleLeOp -> (FCMP TF LE, NE)
2193 genCondJump lbl (StPrim op [x, y])
2194 = trivialCode instr x y `thenNat` \ register ->
2195 getNewRegNCG IntRep `thenNat` \ tmp ->
2197 code = registerCode register tmp
2198 result = registerName register tmp
2199 target = ImmCLbl lbl
2201 returnNat (code . mkSeqInstr (BI cond result target))
2203 (instr, cond) = case op of
2204 CharGtOp -> (CMP LE, EQQ)
2205 CharGeOp -> (CMP LTT, EQQ)
2206 CharEqOp -> (CMP EQQ, NE)
2207 CharNeOp -> (CMP EQQ, EQQ)
2208 CharLtOp -> (CMP LTT, NE)
2209 CharLeOp -> (CMP LE, NE)
2210 IntGtOp -> (CMP LE, EQQ)
2211 IntGeOp -> (CMP LTT, EQQ)
2212 IntEqOp -> (CMP EQQ, NE)
2213 IntNeOp -> (CMP EQQ, EQQ)
2214 IntLtOp -> (CMP LTT, NE)
2215 IntLeOp -> (CMP LE, NE)
2216 WordGtOp -> (CMP ULE, EQQ)
2217 WordGeOp -> (CMP ULT, EQQ)
2218 WordEqOp -> (CMP EQQ, NE)
2219 WordNeOp -> (CMP EQQ, EQQ)
2220 WordLtOp -> (CMP ULT, NE)
2221 WordLeOp -> (CMP ULE, NE)
2222 AddrGtOp -> (CMP ULE, EQQ)
2223 AddrGeOp -> (CMP ULT, EQQ)
2224 AddrEqOp -> (CMP EQQ, NE)
2225 AddrNeOp -> (CMP EQQ, EQQ)
2226 AddrLtOp -> (CMP ULT, NE)
2227 AddrLeOp -> (CMP ULE, NE)
2229 #endif {- alpha_TARGET_ARCH -}
2230 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2231 #if i386_TARGET_ARCH
2233 genCondJump lbl bool
2234 = getCondCode bool `thenNat` \ condition ->
2236 code = condCode condition
2237 cond = condName condition
2238 target = ImmCLbl lbl
2240 returnNat (code `snocOL` JXX cond lbl)
2242 #endif {- i386_TARGET_ARCH -}
2243 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2244 #if sparc_TARGET_ARCH
2246 genCondJump lbl bool
2247 = getCondCode bool `thenNat` \ condition ->
2249 code = condCode condition
2250 cond = condName condition
2251 target = ImmCLbl lbl
2256 if condFloat condition
2257 then [NOP, BF cond False target, NOP]
2258 else [BI cond False target, NOP]
2262 #endif {- sparc_TARGET_ARCH -}
2265 %************************************************************************
2267 \subsection{Generating C calls}
2269 %************************************************************************
2271 Now the biggest nightmare---calls. Most of the nastiness is buried in
2272 @get_arg@, which moves the arguments to the correct registers/stack
2273 locations. Apart from that, the code is easy.
2275 (If applicable) Do not fill the delay slots here; you will confuse the
2280 :: FAST_STRING -- function to call
2282 -> PrimRep -- type of the result
2283 -> [StixTree] -- arguments (of mixed type)
2286 #if alpha_TARGET_ARCH
2288 genCCall fn cconv kind args
2289 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2290 `thenNat` \ ((unused,_), argCode) ->
2292 nRegs = length allArgRegs - length unused
2293 code = asmSeqThen (map ($ []) argCode)
2296 LDA pv (AddrImm (ImmLab (ptext fn))),
2297 JSR ra (AddrReg pv) nRegs,
2298 LDGP gp (AddrReg ra)]
2300 ------------------------
2301 {- Try to get a value into a specific register (or registers) for
2302 a call. The first 6 arguments go into the appropriate
2303 argument register (separate registers for integer and floating
2304 point arguments, but used in lock-step), and the remaining
2305 arguments are dumped to the stack, beginning at 0(sp). Our
2306 first argument is a pair of the list of remaining argument
2307 registers to be assigned for this call and the next stack
2308 offset to use for overflowing arguments. This way,
2309 @get_Arg@ can be applied to all of a call's arguments using
2313 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2314 -> StixTree -- Current argument
2315 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2317 -- We have to use up all of our argument registers first...
2319 get_arg ((iDst,fDst):dsts, offset) arg
2320 = getRegister arg `thenNat` \ register ->
2322 reg = if isFloatingRep pk then fDst else iDst
2323 code = registerCode register reg
2324 src = registerName register reg
2325 pk = registerRep register
2328 if isFloatingRep pk then
2329 ((dsts, offset), if isFixed register then
2330 code . mkSeqInstr (FMOV src fDst)
2333 ((dsts, offset), if isFixed register then
2334 code . mkSeqInstr (OR src (RIReg src) iDst)
2337 -- Once we have run out of argument registers, we move to the
2340 get_arg ([], offset) arg
2341 = getRegister arg `thenNat` \ register ->
2342 getNewRegNCG (registerRep register)
2345 code = registerCode register tmp
2346 src = registerName register tmp
2347 pk = registerRep register
2348 sz = primRepToSize pk
2350 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2352 #endif {- alpha_TARGET_ARCH -}
2353 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2354 #if i386_TARGET_ARCH
2356 genCCall fn cconv kind [StInt i]
2357 | fn == SLIT ("PerformGC_wrapper")
2359 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2360 CALL (ImmLit (ptext (if underscorePrefix
2361 then (SLIT ("_PerformGC_wrapper"))
2362 else (SLIT ("PerformGC_wrapper")))))
2368 genCCall fn cconv kind args
2369 = mapNat get_call_arg
2370 (reverse args) `thenNat` \ sizes_n_codes ->
2371 getDeltaNat `thenNat` \ delta ->
2372 let (sizes, codes) = unzip sizes_n_codes
2373 tot_arg_size = sum sizes
2374 code2 = concatOL codes
2377 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2378 DELTA (delta + tot_arg_size)
2381 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2382 returnNat (code2 `appOL` call)
2385 -- function names that begin with '.' are assumed to be special
2386 -- internally generated names like '.mul,' which don't get an
2387 -- underscore prefix
2388 -- ToDo:needed (WDP 96/03) ???
2389 fn__2 = case (_HEAD_ fn) of
2390 '.' -> ImmLit (ptext fn)
2391 _ -> ImmLab False (ptext fn)
2398 get_call_arg :: StixTree{-current argument-}
2399 -> NatM (Int, InstrBlock) -- argsz, code
2402 = get_op arg `thenNat` \ (code, reg, sz) ->
2403 getDeltaNat `thenNat` \ delta ->
2404 arg_size sz `bind` \ size ->
2405 setDeltaNat (delta-size) `thenNat` \ _ ->
2406 if (case sz of DF -> True; F -> True; _ -> False)
2407 then returnNat (size,
2409 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2411 GST sz reg (AddrBaseIndex (Just esp)
2415 else returnNat (size,
2417 PUSH L (OpReg reg) `snocOL`
2423 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2426 = getRegister op `thenNat` \ register ->
2427 getNewRegNCG (registerRep register)
2430 code = registerCode register tmp
2431 reg = registerName register tmp
2432 pk = registerRep register
2433 sz = primRepToSize pk
2435 returnNat (code, reg, sz)
2437 #endif {- i386_TARGET_ARCH -}
2438 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2439 #if sparc_TARGET_ARCH
2440 genCCall fn cconv kind args
2441 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2442 `thenNat` \ ((unused,_), argCode) ->
2445 nRegs = length allArgRegs - length unused
2446 call = unitOL (CALL fn__2 nRegs False)
2447 code = concatOL argCode
2449 -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args
2450 (move_sp_down, move_sp_up)
2451 = let nn = length args - 3
2454 else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn)))
2456 returnNat (move_sp_down `appOL`
2462 -- function names that begin with '.' are assumed to be special
2463 -- internally generated names like '.mul,' which don't get an
2464 -- underscore prefix
2465 -- ToDo:needed (WDP 96/03) ???
2466 fn__2 = case (_HEAD_ fn) of
2467 '.' -> ImmLit (ptext fn)
2468 _ -> ImmLab False (ptext fn)
2470 ------------------------------------
2471 {- Try to get a value into a specific register (or registers) for
2472 a call. The SPARC calling convention is an absolute
2473 nightmare. The first 6x32 bits of arguments are mapped into
2474 %o0 through %o5, and the remaining arguments are dumped to the
2475 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2476 first argument is a pair of the list of remaining argument
2477 registers to be assigned for this call and the next stack
2478 offset to use for overflowing arguments. This way,
2479 @get_arg@ can be applied to all of a call's arguments using
2482 If we have to put args on the stack, move %o6==%sp down by
2483 8 x the number of args, to ensure there's enough space.
2486 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2487 -> StixTree -- Current argument
2488 -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2490 -- We have to use up all of our argument registers first...
2492 get_arg (dst:dsts, offset) arg
2493 = getRegister arg `thenNat` \ register ->
2494 getNewRegNCG (registerRep register)
2497 reg = if isFloatingRep pk then tmp else dst
2498 code = registerCode register reg
2499 src = registerName register reg
2500 pk = registerRep register
2506 [] -> ( ([], offset + 1),
2508 -- put the second part in the right stack
2509 -- and load the first part into %o5
2510 FMOV DF src f0 `snocOL`
2511 ST F f0 (spRel offset) `snocOL`
2512 LD W (spRel offset) dst `snocOL`
2513 ST F (fPair f0) (spRel offset)
2516 -> ( (dsts__2, offset),
2518 FMOV DF src f0 `snocOL`
2519 ST F f0 (spRel 16) `snocOL`
2520 LD W (spRel 16) dst `snocOL`
2521 ST F (fPair f0) (spRel 16) `snocOL`
2522 LD W (spRel 16) dst__2
2525 -> ( (dsts, offset),
2527 ST F src (spRel 16) `snocOL`
2530 _ -> ( (dsts, offset),
2532 then code `snocOL` OR False g0 (RIReg src) dst
2536 -- Once we have run out of argument registers, we move to the
2539 get_arg ([], offset) arg
2540 = getRegister arg `thenNat` \ register ->
2541 getNewRegNCG (registerRep register)
2544 code = registerCode register tmp
2545 src = registerName register tmp
2546 pk = registerRep register
2547 sz = primRepToSize pk
2548 words = if pk == DoubleRep then 2 else 1
2550 returnNat ( ([], offset + words),
2551 code `snocOL` ST sz src (spRel offset) )
2553 #endif {- sparc_TARGET_ARCH -}
2556 %************************************************************************
2558 \subsection{Support bits}
2560 %************************************************************************
2562 %************************************************************************
2564 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2566 %************************************************************************
2568 Turn those condition codes into integers now (when they appear on
2569 the right hand side of an assignment).
2571 (If applicable) Do not fill the delay slots here; you will confuse the
2575 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2577 #if alpha_TARGET_ARCH
2578 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2579 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2580 #endif {- alpha_TARGET_ARCH -}
2582 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2583 #if i386_TARGET_ARCH
2586 = condIntCode cond x y `thenNat` \ condition ->
2587 getNewRegNCG IntRep `thenNat` \ tmp ->
2589 code = condCode condition
2590 cond = condName condition
2591 code__2 dst = code `appOL` toOL [
2592 SETCC cond (OpReg tmp),
2593 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2594 MOV L (OpReg tmp) (OpReg dst)]
2596 returnNat (Any IntRep code__2)
2599 = getNatLabelNCG `thenNat` \ lbl1 ->
2600 getNatLabelNCG `thenNat` \ lbl2 ->
2601 condFltCode cond x y `thenNat` \ condition ->
2603 code = condCode condition
2604 cond = condName condition
2605 code__2 dst = code `appOL` toOL [
2607 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2610 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2613 returnNat (Any IntRep code__2)
2615 #endif {- i386_TARGET_ARCH -}
2616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2617 #if sparc_TARGET_ARCH
2619 condIntReg EQQ x (StInt 0)
2620 = getRegister x `thenNat` \ register ->
2621 getNewRegNCG IntRep `thenNat` \ tmp ->
2623 code = registerCode register tmp
2624 src = registerName register tmp
2625 code__2 dst = code `appOL` toOL [
2626 SUB False True g0 (RIReg src) g0,
2627 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2629 returnNat (Any IntRep code__2)
2632 = getRegister x `thenNat` \ register1 ->
2633 getRegister y `thenNat` \ register2 ->
2634 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2635 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2637 code1 = registerCode register1 tmp1
2638 src1 = registerName register1 tmp1
2639 code2 = registerCode register2 tmp2
2640 src2 = registerName register2 tmp2
2641 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2642 XOR False src1 (RIReg src2) dst,
2643 SUB False True g0 (RIReg dst) g0,
2644 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2646 returnNat (Any IntRep code__2)
2648 condIntReg NE x (StInt 0)
2649 = getRegister x `thenNat` \ register ->
2650 getNewRegNCG IntRep `thenNat` \ tmp ->
2652 code = registerCode register tmp
2653 src = registerName register tmp
2654 code__2 dst = code `appOL` toOL [
2655 SUB False True g0 (RIReg src) g0,
2656 ADD True False g0 (RIImm (ImmInt 0)) dst]
2658 returnNat (Any IntRep code__2)
2661 = getRegister x `thenNat` \ register1 ->
2662 getRegister y `thenNat` \ register2 ->
2663 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2664 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2666 code1 = registerCode register1 tmp1
2667 src1 = registerName register1 tmp1
2668 code2 = registerCode register2 tmp2
2669 src2 = registerName register2 tmp2
2670 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2671 XOR False src1 (RIReg src2) dst,
2672 SUB False True g0 (RIReg dst) g0,
2673 ADD True False g0 (RIImm (ImmInt 0)) dst]
2675 returnNat (Any IntRep code__2)
2678 = getNatLabelNCG `thenNat` \ lbl1 ->
2679 getNatLabelNCG `thenNat` \ lbl2 ->
2680 condIntCode cond x y `thenNat` \ condition ->
2682 code = condCode condition
2683 cond = condName condition
2684 code__2 dst = code `appOL` toOL [
2685 BI cond False (ImmCLbl lbl1), NOP,
2686 OR False g0 (RIImm (ImmInt 0)) dst,
2687 BI ALWAYS False (ImmCLbl lbl2), NOP,
2689 OR False g0 (RIImm (ImmInt 1)) dst,
2692 returnNat (Any IntRep code__2)
2695 = getNatLabelNCG `thenNat` \ lbl1 ->
2696 getNatLabelNCG `thenNat` \ lbl2 ->
2697 condFltCode cond x y `thenNat` \ condition ->
2699 code = condCode condition
2700 cond = condName condition
2701 code__2 dst = code `appOL` toOL [
2703 BF cond False (ImmCLbl lbl1), NOP,
2704 OR False g0 (RIImm (ImmInt 0)) dst,
2705 BI ALWAYS False (ImmCLbl lbl2), NOP,
2707 OR False g0 (RIImm (ImmInt 1)) dst,
2710 returnNat (Any IntRep code__2)
2712 #endif {- sparc_TARGET_ARCH -}
2715 %************************************************************************
2717 \subsubsection{@trivial*Code@: deal with trivial instructions}
2719 %************************************************************************
2721 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2722 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2723 for constants on the right hand side, because that's where the generic
2724 optimizer will have put them.
2726 Similarly, for unary instructions, we don't have to worry about
2727 matching an StInt as the argument, because genericOpt will already
2728 have handled the constant-folding.
2732 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2733 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2734 -> Maybe (Operand -> Operand -> Instr)
2735 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2737 -> StixTree -> StixTree -- the two arguments
2742 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2743 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2744 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2746 -> StixTree -> StixTree -- the two arguments
2750 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2751 ,IF_ARCH_i386 ((Operand -> Instr)
2752 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2754 -> StixTree -- the one argument
2759 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2760 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2761 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2763 -> StixTree -- the one argument
2766 #if alpha_TARGET_ARCH
2768 trivialCode instr x (StInt y)
2770 = getRegister x `thenNat` \ register ->
2771 getNewRegNCG IntRep `thenNat` \ tmp ->
2773 code = registerCode register tmp
2774 src1 = registerName register tmp
2775 src2 = ImmInt (fromInteger y)
2776 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2778 returnNat (Any IntRep code__2)
2780 trivialCode instr x y
2781 = getRegister x `thenNat` \ register1 ->
2782 getRegister y `thenNat` \ register2 ->
2783 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2784 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2786 code1 = registerCode register1 tmp1 []
2787 src1 = registerName register1 tmp1
2788 code2 = registerCode register2 tmp2 []
2789 src2 = registerName register2 tmp2
2790 code__2 dst = asmSeqThen [code1, code2] .
2791 mkSeqInstr (instr src1 (RIReg src2) dst)
2793 returnNat (Any IntRep code__2)
2796 trivialUCode instr x
2797 = getRegister x `thenNat` \ register ->
2798 getNewRegNCG IntRep `thenNat` \ tmp ->
2800 code = registerCode register tmp
2801 src = registerName register tmp
2802 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2804 returnNat (Any IntRep code__2)
2807 trivialFCode _ instr x y
2808 = getRegister x `thenNat` \ register1 ->
2809 getRegister y `thenNat` \ register2 ->
2810 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2811 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2813 code1 = registerCode register1 tmp1
2814 src1 = registerName register1 tmp1
2816 code2 = registerCode register2 tmp2
2817 src2 = registerName register2 tmp2
2819 code__2 dst = asmSeqThen [code1 [], code2 []] .
2820 mkSeqInstr (instr src1 src2 dst)
2822 returnNat (Any DoubleRep code__2)
2824 trivialUFCode _ instr x
2825 = getRegister x `thenNat` \ register ->
2826 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2828 code = registerCode register tmp
2829 src = registerName register tmp
2830 code__2 dst = code . mkSeqInstr (instr src dst)
2832 returnNat (Any DoubleRep code__2)
2834 #endif {- alpha_TARGET_ARCH -}
2835 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2836 #if i386_TARGET_ARCH
2838 The Rules of the Game are:
2840 * You cannot assume anything about the destination register dst;
2841 it may be anything, including a fixed reg.
2843 * You may compute an operand into a fixed reg, but you may not
2844 subsequently change the contents of that fixed reg. If you
2845 want to do so, first copy the value either to a temporary
2846 or into dst. You are free to modify dst even if it happens
2847 to be a fixed reg -- that's not your problem.
2849 * You cannot assume that a fixed reg will stay live over an
2850 arbitrary computation. The same applies to the dst reg.
2852 * Temporary regs obtained from getNewRegNCG are distinct from
2853 each other and from all other regs, and stay live over
2854 arbitrary computations.
2858 trivialCode instr maybe_revinstr a b
2861 = getRegister a `thenNat` \ rega ->
2864 then registerCode rega dst `bind` \ code_a ->
2866 instr (OpImm imm_b) (OpReg dst)
2867 else registerCodeF rega `bind` \ code_a ->
2868 registerNameF rega `bind` \ r_a ->
2870 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2871 instr (OpImm imm_b) (OpReg dst)
2873 returnNat (Any IntRep mkcode)
2876 = getRegister b `thenNat` \ regb ->
2877 getNewRegNCG IntRep `thenNat` \ tmp ->
2878 let revinstr_avail = maybeToBool maybe_revinstr
2879 revinstr = case maybe_revinstr of Just ri -> ri
2883 then registerCode regb dst `bind` \ code_b ->
2885 revinstr (OpImm imm_a) (OpReg dst)
2886 else registerCodeF regb `bind` \ code_b ->
2887 registerNameF regb `bind` \ r_b ->
2889 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2890 revinstr (OpImm imm_a) (OpReg dst)
2894 then registerCode regb tmp `bind` \ code_b ->
2896 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2897 instr (OpReg tmp) (OpReg dst)
2898 else registerCodeF regb `bind` \ code_b ->
2899 registerNameF regb `bind` \ r_b ->
2901 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2902 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2903 instr (OpReg tmp) (OpReg dst)
2905 returnNat (Any IntRep mkcode)
2908 = getRegister a `thenNat` \ rega ->
2909 getRegister b `thenNat` \ regb ->
2910 getNewRegNCG IntRep `thenNat` \ tmp ->
2912 = case (isAny rega, isAny regb) of
2914 -> registerCode regb tmp `bind` \ code_b ->
2915 registerCode rega dst `bind` \ code_a ->
2918 instr (OpReg tmp) (OpReg dst)
2920 -> registerCode rega tmp `bind` \ code_a ->
2921 registerCodeF regb `bind` \ code_b ->
2922 registerNameF regb `bind` \ r_b ->
2925 instr (OpReg r_b) (OpReg tmp) `snocOL`
2926 MOV L (OpReg tmp) (OpReg dst)
2928 -> registerCode regb tmp `bind` \ code_b ->
2929 registerCodeF rega `bind` \ code_a ->
2930 registerNameF rega `bind` \ r_a ->
2933 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2934 instr (OpReg tmp) (OpReg dst)
2936 -> registerCodeF rega `bind` \ code_a ->
2937 registerNameF rega `bind` \ r_a ->
2938 registerCodeF regb `bind` \ code_b ->
2939 registerNameF regb `bind` \ r_b ->
2941 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2943 instr (OpReg r_b) (OpReg tmp) `snocOL`
2944 MOV L (OpReg tmp) (OpReg dst)
2946 returnNat (Any IntRep mkcode)
2949 maybe_imm_a = maybeImm a
2950 is_imm_a = maybeToBool maybe_imm_a
2951 imm_a = case maybe_imm_a of Just imm -> imm
2953 maybe_imm_b = maybeImm b
2954 is_imm_b = maybeToBool maybe_imm_b
2955 imm_b = case maybe_imm_b of Just imm -> imm
2959 trivialUCode instr x
2960 = getRegister x `thenNat` \ register ->
2962 code__2 dst = let code = registerCode register dst
2963 src = registerName register dst
2965 if isFixed register && dst /= src
2966 then toOL [MOV L (OpReg src) (OpReg dst),
2968 else unitOL (instr (OpReg src))
2970 returnNat (Any IntRep code__2)
2973 trivialFCode pk instr x y
2974 = getRegister x `thenNat` \ register1 ->
2975 getRegister y `thenNat` \ register2 ->
2976 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2977 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2979 code1 = registerCode register1 tmp1
2980 src1 = registerName register1 tmp1
2982 code2 = registerCode register2 tmp2
2983 src2 = registerName register2 tmp2
2986 -- treat the common case specially: both operands in
2988 | isAny register1 && isAny register2
2991 instr (primRepToSize pk) src1 src2 dst
2993 -- be paranoid (and inefficient)
2995 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2997 instr (primRepToSize pk) tmp1 src2 dst
2999 returnNat (Any pk code__2)
3003 trivialUFCode pk instr x
3004 = getRegister x `thenNat` \ register ->
3005 getNewRegNCG pk `thenNat` \ tmp ->
3007 code = registerCode register tmp
3008 src = registerName register tmp
3009 code__2 dst = code `snocOL` instr src dst
3011 returnNat (Any pk code__2)
3013 #endif {- i386_TARGET_ARCH -}
3014 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3015 #if sparc_TARGET_ARCH
3017 trivialCode instr x (StInt y)
3019 = getRegister x `thenNat` \ register ->
3020 getNewRegNCG IntRep `thenNat` \ tmp ->
3022 code = registerCode register tmp
3023 src1 = registerName register tmp
3024 src2 = ImmInt (fromInteger y)
3025 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3027 returnNat (Any IntRep code__2)
3029 trivialCode instr x y
3030 = getRegister x `thenNat` \ register1 ->
3031 getRegister y `thenNat` \ register2 ->
3032 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3033 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3035 code1 = registerCode register1 tmp1
3036 src1 = registerName register1 tmp1
3037 code2 = registerCode register2 tmp2
3038 src2 = registerName register2 tmp2
3039 code__2 dst = code1 `appOL` code2 `snocOL`
3040 instr src1 (RIReg src2) dst
3042 returnNat (Any IntRep code__2)
3045 trivialFCode pk instr x y
3046 = getRegister x `thenNat` \ register1 ->
3047 getRegister y `thenNat` \ register2 ->
3048 getNewRegNCG (registerRep register1)
3050 getNewRegNCG (registerRep register2)
3052 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3054 promote x = FxTOy F DF x tmp
3056 pk1 = registerRep register1
3057 code1 = registerCode register1 tmp1
3058 src1 = registerName register1 tmp1
3060 pk2 = registerRep register2
3061 code2 = registerCode register2 tmp2
3062 src2 = registerName register2 tmp2
3066 code1 `appOL` code2 `snocOL`
3067 instr (primRepToSize pk) src1 src2 dst
3068 else if pk1 == FloatRep then
3069 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3070 instr DF tmp src2 dst
3072 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3073 instr DF src1 tmp dst
3075 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3078 trivialUCode instr x
3079 = getRegister x `thenNat` \ register ->
3080 getNewRegNCG IntRep `thenNat` \ tmp ->
3082 code = registerCode register tmp
3083 src = registerName register tmp
3084 code__2 dst = code `snocOL` instr (RIReg src) dst
3086 returnNat (Any IntRep code__2)
3089 trivialUFCode pk instr x
3090 = getRegister x `thenNat` \ register ->
3091 getNewRegNCG pk `thenNat` \ tmp ->
3093 code = registerCode register tmp
3094 src = registerName register tmp
3095 code__2 dst = code `snocOL` instr src dst
3097 returnNat (Any pk code__2)
3099 #endif {- sparc_TARGET_ARCH -}
3102 %************************************************************************
3104 \subsubsection{Coercing to/from integer/floating-point...}
3106 %************************************************************************
3108 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3109 to be generated. Here we just change the type on the Register passed
3110 on up. The code is machine-independent.
3112 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3113 conversions. We have to store temporaries in memory to move
3114 between the integer and the floating point register sets.
3117 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3118 coerceFltCode :: StixTree -> NatM Register
3120 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3121 coerceFP2Int :: StixTree -> NatM Register
3124 = getRegister x `thenNat` \ register ->
3127 Fixed _ reg code -> Fixed pk reg code
3128 Any _ code -> Any pk code
3133 = getRegister x `thenNat` \ register ->
3136 Fixed _ reg code -> Fixed DoubleRep reg code
3137 Any _ code -> Any DoubleRep code
3142 #if alpha_TARGET_ARCH
3145 = getRegister x `thenNat` \ register ->
3146 getNewRegNCG IntRep `thenNat` \ reg ->
3148 code = registerCode register reg
3149 src = registerName register reg
3151 code__2 dst = code . mkSeqInstrs [
3153 LD TF dst (spRel 0),
3156 returnNat (Any DoubleRep code__2)
3160 = getRegister x `thenNat` \ register ->
3161 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3163 code = registerCode register tmp
3164 src = registerName register tmp
3166 code__2 dst = code . mkSeqInstrs [
3168 ST TF tmp (spRel 0),
3171 returnNat (Any IntRep code__2)
3173 #endif {- alpha_TARGET_ARCH -}
3174 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3175 #if i386_TARGET_ARCH
3178 = getRegister x `thenNat` \ register ->
3179 getNewRegNCG IntRep `thenNat` \ reg ->
3181 code = registerCode register reg
3182 src = registerName register reg
3183 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3184 code__2 dst = code `snocOL` opc src dst
3186 returnNat (Any pk code__2)
3190 = getRegister x `thenNat` \ register ->
3191 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3193 code = registerCode register tmp
3194 src = registerName register tmp
3195 pk = registerRep register
3197 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3198 code__2 dst = code `snocOL` opc src dst
3200 returnNat (Any IntRep code__2)
3202 #endif {- i386_TARGET_ARCH -}
3203 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3204 #if sparc_TARGET_ARCH
3207 = getRegister x `thenNat` \ register ->
3208 getNewRegNCG IntRep `thenNat` \ reg ->
3210 code = registerCode register reg
3211 src = registerName register reg
3213 code__2 dst = code `appOL` toOL [
3214 ST W src (spRel (-2)),
3215 LD W (spRel (-2)) dst,
3216 FxTOy W (primRepToSize pk) dst dst]
3218 returnNat (Any pk code__2)
3222 = getRegister x `thenNat` \ register ->
3223 getNewRegNCG IntRep `thenNat` \ reg ->
3224 getNewRegNCG FloatRep `thenNat` \ tmp ->
3226 code = registerCode register reg
3227 src = registerName register reg
3228 pk = registerRep register
3230 code__2 dst = code `appOL` toOL [
3231 FxTOy (primRepToSize pk) W src tmp,
3232 ST W tmp (spRel (-2)),
3233 LD W (spRel (-2)) dst]
3235 returnNat (Any IntRep code__2)
3237 #endif {- sparc_TARGET_ARCH -}
3240 %************************************************************************
3242 \subsubsection{Coercing integer to @Char@...}
3244 %************************************************************************
3246 Integer to character conversion. Where applicable, we try to do this
3247 in one step if the original object is in memory.
3250 chrCode :: StixTree -> NatM Register
3252 #if alpha_TARGET_ARCH
3255 = getRegister x `thenNat` \ register ->
3256 getNewRegNCG IntRep `thenNat` \ reg ->
3258 code = registerCode register reg
3259 src = registerName register reg
3260 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3262 returnNat (Any IntRep code__2)
3264 #endif {- alpha_TARGET_ARCH -}
3265 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3266 #if i386_TARGET_ARCH
3269 = getRegister x `thenNat` \ register ->
3272 code = registerCode register dst
3273 src = registerName register dst
3275 if isFixed register && src /= dst
3276 then toOL [MOV L (OpReg src) (OpReg dst),
3277 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3278 else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3280 returnNat (Any IntRep code__2)
3282 #endif {- i386_TARGET_ARCH -}
3283 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3284 #if sparc_TARGET_ARCH
3286 chrCode (StInd pk mem)
3287 = getAmode mem `thenNat` \ amode ->
3289 code = amodeCode amode
3290 src = amodeAddr amode
3291 src_off = addrOffset src 3
3292 src__2 = case src_off of Just x -> x
3293 code__2 dst = if maybeToBool src_off then
3294 code `snocOL` LD BU src__2 dst
3297 LD (primRepToSize pk) src dst `snocOL`
3298 AND False dst (RIImm (ImmInt 255)) dst
3300 returnNat (Any pk code__2)
3303 = getRegister x `thenNat` \ register ->
3304 getNewRegNCG IntRep `thenNat` \ reg ->
3306 code = registerCode register reg
3307 src = registerName register reg
3308 code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
3310 returnNat (Any IntRep code__2)
3312 #endif {- sparc_TARGET_ARCH -}