2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmt2Instrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv, stdCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 DestInfo, hasDestInfo,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
61 stmt2Instrs stmt = case stmt of
62 StComment s -> returnNat (unitOL (COMMENT s))
63 StSegment seg -> returnNat (unitOL (SEGMENT seg))
65 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
67 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
70 StLabel lab -> returnNat (unitOL (LABEL lab))
72 StJump dsts arg -> genJump dsts (derefDLL arg)
73 StCondJump lab arg -> genCondJump lab (derefDLL arg)
75 -- A call returning void, ie one done for its side-effects
76 StCall fn cconv VoidRep args -> genCCall fn
77 cconv VoidRep (map derefDLL args)
80 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
81 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
84 -- When falling through on the Alpha, we still have to load pv
85 -- with the address of the next routine, so that it can load gp.
86 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
90 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
91 returnNat (DATA (primRepToSize kind) imms
92 `consOL` concatOL codes)
94 getData :: StixTree -> NatM (InstrBlock, Imm)
96 getData (StInt i) = returnNat (nilOL, ImmInteger i)
97 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
98 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
99 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
100 getData (StString s) =
101 getNatLabelNCG `thenNat` \ lbl ->
102 returnNat (toOL [LABEL lbl,
103 ASCII True (_UNPK_ s)],
105 -- the linker can handle simple arithmetic...
106 getData (StIndex rep (StCLbl lbl) (StInt off)) =
108 ImmIndex lbl (fromInteger (off * sizeOf rep)))
110 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
111 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
112 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
114 derefDLL :: StixTree -> StixTree
116 | opt_Static -- short out the entire deal if not doing DLLs
123 StCLbl lbl -> if labelDynamic lbl
124 then StInd PtrRep (StCLbl lbl)
126 -- all the rest are boring
127 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
128 StPrim pk args -> StPrim pk (map qq args)
129 StInd pk addr -> StInd pk (qq addr)
130 StCall who cc pk args -> StCall who cc pk (map qq args)
137 _ -> pprPanic "derefDLL: unhandled case"
141 %************************************************************************
143 \subsection{General things for putting together code sequences}
145 %************************************************************************
148 mangleIndexTree :: StixTree -> StixTree
150 mangleIndexTree (StIndex pk base (StInt i))
151 = StPrim IntAddOp [base, off]
153 off = StInt (i * sizeOf pk)
155 mangleIndexTree (StIndex pk base off)
159 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
160 if s == 0 then off else StPrim SllOp [off, StInt s]
163 shift DoubleRep = 3::Integer
164 shift CharRep = 2::Integer
165 shift Int8Rep = 0::Integer
166 shift _ = IF_ARCH_alpha(3,2)
170 maybeImm :: StixTree -> Maybe Imm
174 maybeImm (StIndex rep (StCLbl l) (StInt off))
175 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
177 | i >= toInteger minInt && i <= toInteger maxInt
178 = Just (ImmInt (fromInteger i))
180 = Just (ImmInteger i)
185 %************************************************************************
187 \subsection{The @Register@ type}
189 %************************************************************************
191 @Register@s passed up the tree. If the stix code forces the register
192 to live in a pre-decided machine register, it comes out as @Fixed@;
193 otherwise, it comes out as @Any@, and the parent can decide which
194 register to put it in.
198 = Fixed PrimRep Reg InstrBlock
199 | Any PrimRep (Reg -> InstrBlock)
201 registerCode :: Register -> Reg -> InstrBlock
202 registerCode (Fixed _ _ code) reg = code
203 registerCode (Any _ code) reg = code reg
205 registerCodeF (Fixed _ _ code) = code
206 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
208 registerCodeA (Any _ code) = code
209 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
211 registerName :: Register -> Reg -> Reg
212 registerName (Fixed _ reg _) _ = reg
213 registerName (Any _ _) reg = reg
215 registerNameF (Fixed _ reg _) = reg
216 registerNameF (Any _ _) = pprPanic "registerNameF" empty
218 registerRep :: Register -> PrimRep
219 registerRep (Fixed pk _ _) = pk
220 registerRep (Any pk _) = pk
222 {-# INLINE registerCode #-}
223 {-# INLINE registerCodeF #-}
224 {-# INLINE registerName #-}
225 {-# INLINE registerNameF #-}
226 {-# INLINE registerRep #-}
227 {-# INLINE isFixed #-}
230 isFixed, isAny :: Register -> Bool
231 isFixed (Fixed _ _ _) = True
232 isFixed (Any _ _) = False
234 isAny = not . isFixed
237 Generate code to get a subtree into a @Register@:
239 getRegister :: StixTree -> NatM Register
241 getRegister (StReg (StixMagicId stgreg))
242 = case (magicIdRegMaybe stgreg) of
243 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
246 getRegister (StReg (StixTemp u pk))
247 = returnNat (Fixed pk (mkVReg u pk) nilOL)
249 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
251 getRegister (StCall fn cconv kind args)
252 = genCCall fn cconv kind args `thenNat` \ call ->
253 returnNat (Fixed kind reg call)
255 reg = if isFloatingRep kind
256 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
257 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
259 getRegister (StString s)
260 = getNatLabelNCG `thenNat` \ lbl ->
262 imm_lbl = ImmCLbl lbl
265 SEGMENT RoDataSegment,
267 ASCII True (_UNPK_ s),
269 #if alpha_TARGET_ARCH
270 LDA dst (AddrImm imm_lbl)
273 MOV L (OpImm imm_lbl) (OpReg dst)
275 #if sparc_TARGET_ARCH
276 SETHI (HI imm_lbl) dst,
277 OR False dst (RIImm (LO imm_lbl)) dst
281 returnNat (Any PtrRep code)
285 -- end of machine-"independent" bit; here we go on the rest...
287 #if alpha_TARGET_ARCH
289 getRegister (StDouble d)
290 = getNatLabelNCG `thenNat` \ lbl ->
291 getNewRegNCG PtrRep `thenNat` \ tmp ->
292 let code dst = mkSeqInstrs [
295 DATA TF [ImmLab (rational d)],
297 LDA tmp (AddrImm (ImmCLbl lbl)),
298 LD TF dst (AddrReg tmp)]
300 returnNat (Any DoubleRep code)
302 getRegister (StPrim primop [x]) -- unary PrimOps
304 IntNegOp -> trivialUCode (NEG Q False) x
306 NotOp -> trivialUCode NOT x
308 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
309 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
311 OrdOp -> coerceIntCode IntRep x
314 Float2IntOp -> coerceFP2Int x
315 Int2FloatOp -> coerceInt2FP pr x
316 Double2IntOp -> coerceFP2Int x
317 Int2DoubleOp -> coerceInt2FP pr x
319 Double2FloatOp -> coerceFltCode x
320 Float2DoubleOp -> coerceFltCode x
322 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
324 fn = case other_op of
325 FloatExpOp -> SLIT("exp")
326 FloatLogOp -> SLIT("log")
327 FloatSqrtOp -> SLIT("sqrt")
328 FloatSinOp -> SLIT("sin")
329 FloatCosOp -> SLIT("cos")
330 FloatTanOp -> SLIT("tan")
331 FloatAsinOp -> SLIT("asin")
332 FloatAcosOp -> SLIT("acos")
333 FloatAtanOp -> SLIT("atan")
334 FloatSinhOp -> SLIT("sinh")
335 FloatCoshOp -> SLIT("cosh")
336 FloatTanhOp -> SLIT("tanh")
337 DoubleExpOp -> SLIT("exp")
338 DoubleLogOp -> SLIT("log")
339 DoubleSqrtOp -> SLIT("sqrt")
340 DoubleSinOp -> SLIT("sin")
341 DoubleCosOp -> SLIT("cos")
342 DoubleTanOp -> SLIT("tan")
343 DoubleAsinOp -> SLIT("asin")
344 DoubleAcosOp -> SLIT("acos")
345 DoubleAtanOp -> SLIT("atan")
346 DoubleSinhOp -> SLIT("sinh")
347 DoubleCoshOp -> SLIT("cosh")
348 DoubleTanhOp -> SLIT("tanh")
350 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
352 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
354 CharGtOp -> trivialCode (CMP LTT) y x
355 CharGeOp -> trivialCode (CMP LE) y x
356 CharEqOp -> trivialCode (CMP EQQ) x y
357 CharNeOp -> int_NE_code x y
358 CharLtOp -> trivialCode (CMP LTT) x y
359 CharLeOp -> trivialCode (CMP LE) x y
361 IntGtOp -> trivialCode (CMP LTT) y x
362 IntGeOp -> trivialCode (CMP LE) y x
363 IntEqOp -> trivialCode (CMP EQQ) x y
364 IntNeOp -> int_NE_code x y
365 IntLtOp -> trivialCode (CMP LTT) x y
366 IntLeOp -> trivialCode (CMP LE) x y
368 WordGtOp -> trivialCode (CMP ULT) y x
369 WordGeOp -> trivialCode (CMP ULE) x y
370 WordEqOp -> trivialCode (CMP EQQ) x y
371 WordNeOp -> int_NE_code x y
372 WordLtOp -> trivialCode (CMP ULT) x y
373 WordLeOp -> trivialCode (CMP ULE) x y
375 AddrGtOp -> trivialCode (CMP ULT) y x
376 AddrGeOp -> trivialCode (CMP ULE) y x
377 AddrEqOp -> trivialCode (CMP EQQ) x y
378 AddrNeOp -> int_NE_code x y
379 AddrLtOp -> trivialCode (CMP ULT) x y
380 AddrLeOp -> trivialCode (CMP ULE) x y
382 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
383 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
384 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
385 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
386 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
387 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
389 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
390 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
391 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
392 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
393 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
394 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
396 IntAddOp -> trivialCode (ADD Q False) x y
397 IntSubOp -> trivialCode (SUB Q False) x y
398 IntMulOp -> trivialCode (MUL Q False) x y
399 IntQuotOp -> trivialCode (DIV Q False) x y
400 IntRemOp -> trivialCode (REM Q False) x y
402 WordQuotOp -> trivialCode (DIV Q True) x y
403 WordRemOp -> trivialCode (REM Q True) x y
405 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
406 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
407 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
408 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
410 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
411 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
412 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
413 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
415 AndOp -> trivialCode AND x y
416 OrOp -> trivialCode OR x y
417 XorOp -> trivialCode XOR x y
418 SllOp -> trivialCode SLL x y
419 SrlOp -> trivialCode SRL x y
421 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
422 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
423 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
425 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
426 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
428 {- ------------------------------------------------------------
429 Some bizarre special code for getting condition codes into
430 registers. Integer non-equality is a test for equality
431 followed by an XOR with 1. (Integer comparisons always set
432 the result register to 0 or 1.) Floating point comparisons of
433 any kind leave the result in a floating point register, so we
434 need to wrangle an integer register out of things.
436 int_NE_code :: StixTree -> StixTree -> NatM Register
439 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
440 getNewRegNCG IntRep `thenNat` \ tmp ->
442 code = registerCode register tmp
443 src = registerName register tmp
444 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
446 returnNat (Any IntRep code__2)
448 {- ------------------------------------------------------------
449 Comments for int_NE_code also apply to cmpF_code
452 :: (Reg -> Reg -> Reg -> Instr)
454 -> StixTree -> StixTree
457 cmpF_code instr cond x y
458 = trivialFCode pr instr x y `thenNat` \ register ->
459 getNewRegNCG DoubleRep `thenNat` \ tmp ->
460 getNatLabelNCG `thenNat` \ lbl ->
462 code = registerCode register tmp
463 result = registerName register tmp
465 code__2 dst = code . mkSeqInstrs [
466 OR zeroh (RIImm (ImmInt 1)) dst,
467 BF cond result (ImmCLbl lbl),
468 OR zeroh (RIReg zeroh) dst,
471 returnNat (Any IntRep code__2)
473 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
474 ------------------------------------------------------------
476 getRegister (StInd pk mem)
477 = getAmode mem `thenNat` \ amode ->
479 code = amodeCode amode
480 src = amodeAddr amode
481 size = primRepToSize pk
482 code__2 dst = code . mkSeqInstr (LD size dst src)
484 returnNat (Any pk code__2)
486 getRegister (StInt i)
489 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
491 returnNat (Any IntRep code)
494 code dst = mkSeqInstr (LDI Q dst src)
496 returnNat (Any IntRep code)
498 src = ImmInt (fromInteger i)
503 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
505 returnNat (Any PtrRep code)
508 imm__2 = case imm of Just x -> x
510 #endif {- alpha_TARGET_ARCH -}
511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
514 getRegister (StFloat f)
515 = getNatLabelNCG `thenNat` \ lbl ->
516 let code dst = toOL [
521 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
524 returnNat (Any FloatRep code)
527 getRegister (StDouble d)
530 = let code dst = unitOL (GLDZ dst)
531 in returnNat (Any DoubleRep code)
534 = let code dst = unitOL (GLD1 dst)
535 in returnNat (Any DoubleRep code)
538 = getNatLabelNCG `thenNat` \ lbl ->
539 let code dst = toOL [
542 DATA DF [ImmDouble d],
544 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
547 returnNat (Any DoubleRep code)
549 -- Calculate the offset for (i+1) words above the _initial_
550 -- %esp value by first determining the current offset of it.
551 getRegister (StScratchWord i)
553 = getDeltaNat `thenNat` \ current_stack_offset ->
554 let j = i+1 - (current_stack_offset `div` 4)
556 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
558 returnNat (Any PtrRep code)
560 getRegister (StPrim primop [x]) -- unary PrimOps
562 IntNegOp -> trivialUCode (NEGI L) x
563 NotOp -> trivialUCode (NOT L) x
565 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
566 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
568 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
569 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
571 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
572 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
574 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
575 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
577 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
578 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
580 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
581 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
583 OrdOp -> coerceIntCode IntRep x
586 Float2IntOp -> coerceFP2Int x
587 Int2FloatOp -> coerceInt2FP FloatRep x
588 Double2IntOp -> coerceFP2Int x
589 Int2DoubleOp -> coerceInt2FP DoubleRep x
592 getRegister (StCall fn cCallConv DoubleRep [x])
596 FloatExpOp -> (True, SLIT("exp"))
597 FloatLogOp -> (True, SLIT("log"))
599 FloatAsinOp -> (True, SLIT("asin"))
600 FloatAcosOp -> (True, SLIT("acos"))
601 FloatAtanOp -> (True, SLIT("atan"))
603 FloatSinhOp -> (True, SLIT("sinh"))
604 FloatCoshOp -> (True, SLIT("cosh"))
605 FloatTanhOp -> (True, SLIT("tanh"))
607 DoubleExpOp -> (False, SLIT("exp"))
608 DoubleLogOp -> (False, SLIT("log"))
610 DoubleAsinOp -> (False, SLIT("asin"))
611 DoubleAcosOp -> (False, SLIT("acos"))
612 DoubleAtanOp -> (False, SLIT("atan"))
614 DoubleSinhOp -> (False, SLIT("sinh"))
615 DoubleCoshOp -> (False, SLIT("cosh"))
616 DoubleTanhOp -> (False, SLIT("tanh"))
619 -> pprPanic "getRegister(x86,unary primop)"
620 (pprStixTree (StPrim primop [x]))
622 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
624 CharGtOp -> condIntReg GTT x y
625 CharGeOp -> condIntReg GE x y
626 CharEqOp -> condIntReg EQQ x y
627 CharNeOp -> condIntReg NE x y
628 CharLtOp -> condIntReg LTT x y
629 CharLeOp -> condIntReg LE x y
631 IntGtOp -> condIntReg GTT x y
632 IntGeOp -> condIntReg GE x y
633 IntEqOp -> condIntReg EQQ x y
634 IntNeOp -> condIntReg NE x y
635 IntLtOp -> condIntReg LTT x y
636 IntLeOp -> condIntReg LE x y
638 WordGtOp -> condIntReg GU x y
639 WordGeOp -> condIntReg GEU x y
640 WordEqOp -> condIntReg EQQ x y
641 WordNeOp -> condIntReg NE x y
642 WordLtOp -> condIntReg LU x y
643 WordLeOp -> condIntReg LEU x y
645 AddrGtOp -> condIntReg GU x y
646 AddrGeOp -> condIntReg GEU x y
647 AddrEqOp -> condIntReg EQQ x y
648 AddrNeOp -> condIntReg NE x y
649 AddrLtOp -> condIntReg LU x y
650 AddrLeOp -> condIntReg LEU x y
652 FloatGtOp -> condFltReg GTT x y
653 FloatGeOp -> condFltReg GE x y
654 FloatEqOp -> condFltReg EQQ x y
655 FloatNeOp -> condFltReg NE x y
656 FloatLtOp -> condFltReg LTT x y
657 FloatLeOp -> condFltReg LE x y
659 DoubleGtOp -> condFltReg GTT x y
660 DoubleGeOp -> condFltReg GE x y
661 DoubleEqOp -> condFltReg EQQ x y
662 DoubleNeOp -> condFltReg NE x y
663 DoubleLtOp -> condFltReg LTT x y
664 DoubleLeOp -> condFltReg LE x y
666 IntAddOp -> add_code L x y
667 IntSubOp -> sub_code L x y
668 IntQuotOp -> trivialCode (IQUOT L) Nothing x y
669 IntRemOp -> trivialCode (IREM L) Nothing x y
670 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
672 FloatAddOp -> trivialFCode FloatRep GADD x y
673 FloatSubOp -> trivialFCode FloatRep GSUB x y
674 FloatMulOp -> trivialFCode FloatRep GMUL x y
675 FloatDivOp -> trivialFCode FloatRep GDIV x y
677 DoubleAddOp -> trivialFCode DoubleRep GADD x y
678 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
679 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
680 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
682 AndOp -> let op = AND L in trivialCode op (Just op) x y
683 OrOp -> let op = OR L in trivialCode op (Just op) x y
684 XorOp -> let op = XOR L in trivialCode op (Just op) x y
686 {- Shift ops on x86s have constraints on their source, it
687 either has to be Imm, CL or 1
688 => trivialCode's is not restrictive enough (sigh.)
691 SllOp -> shift_code (SHL L) x y {-False-}
692 SrlOp -> shift_code (SHR L) x y {-False-}
693 ISllOp -> shift_code (SHL L) x y {-False-}
694 ISraOp -> shift_code (SAR L) x y {-False-}
695 ISrlOp -> shift_code (SHR L) x y {-False-}
697 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
698 [promote x, promote y])
699 where promote x = StPrim Float2DoubleOp [x]
700 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
703 -> pprPanic "getRegister(x86,dyadic primop)"
704 (pprStixTree (StPrim primop [x, y]))
708 shift_code :: (Imm -> Operand -> Instr)
713 {- Case1: shift length as immediate -}
714 -- Code is the same as the first eq. for trivialCode -- sigh.
715 shift_code instr x y{-amount-}
717 = getRegister x `thenNat` \ regx ->
720 then registerCodeA regx dst `bind` \ code_x ->
722 instr imm__2 (OpReg dst)
723 else registerCodeF regx `bind` \ code_x ->
724 registerNameF regx `bind` \ r_x ->
726 MOV L (OpReg r_x) (OpReg dst) `snocOL`
727 instr imm__2 (OpReg dst)
729 returnNat (Any IntRep mkcode)
732 imm__2 = case imm of Just x -> x
734 {- Case2: shift length is complex (non-immediate) -}
735 -- Since ECX is always used as a spill temporary, we can't
736 -- use it here to do non-immediate shifts. No big deal --
737 -- they are only very rare, and we can use an equivalent
738 -- test-and-jump sequence which doesn't use ECX.
739 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
740 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
741 shift_code instr x y{-amount-}
742 = getRegister x `thenNat` \ register1 ->
743 getRegister y `thenNat` \ register2 ->
744 getNatLabelNCG `thenNat` \ lbl_test3 ->
745 getNatLabelNCG `thenNat` \ lbl_test2 ->
746 getNatLabelNCG `thenNat` \ lbl_test1 ->
747 getNatLabelNCG `thenNat` \ lbl_test0 ->
748 getNatLabelNCG `thenNat` \ lbl_after ->
749 getNewRegNCG IntRep `thenNat` \ tmp ->
751 = let src_val = registerName register1 dst
752 code_val = registerCode register1 dst
753 src_amt = registerName register2 tmp
754 code_amt = registerCode register2 tmp
759 MOV L (OpReg src_amt) r_tmp `appOL`
761 MOV L (OpReg src_val) r_dst `appOL`
763 COMMENT (_PK_ "begin shift sequence"),
764 MOV L (OpReg src_val) r_dst,
765 MOV L (OpReg src_amt) r_tmp,
767 BT L (ImmInt 4) r_tmp,
769 instr (ImmInt 16) r_dst,
772 BT L (ImmInt 3) r_tmp,
774 instr (ImmInt 8) r_dst,
777 BT L (ImmInt 2) r_tmp,
779 instr (ImmInt 4) r_dst,
782 BT L (ImmInt 1) r_tmp,
784 instr (ImmInt 2) r_dst,
787 BT L (ImmInt 0) r_tmp,
789 instr (ImmInt 1) r_dst,
792 COMMENT (_PK_ "end shift sequence")
795 returnNat (Any IntRep code__2)
798 add_code :: Size -> StixTree -> StixTree -> NatM Register
800 add_code sz x (StInt y)
801 = getRegister x `thenNat` \ register ->
802 getNewRegNCG IntRep `thenNat` \ tmp ->
804 code = registerCode register tmp
805 src1 = registerName register tmp
806 src2 = ImmInt (fromInteger y)
809 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
812 returnNat (Any IntRep code__2)
814 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
817 sub_code :: Size -> StixTree -> StixTree -> NatM Register
819 sub_code sz x (StInt y)
820 = getRegister x `thenNat` \ register ->
821 getNewRegNCG IntRep `thenNat` \ tmp ->
823 code = registerCode register tmp
824 src1 = registerName register tmp
825 src2 = ImmInt (-(fromInteger y))
828 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
831 returnNat (Any IntRep code__2)
833 sub_code sz x y = trivialCode (SUB sz) Nothing x y
836 getRegister (StInd pk mem)
837 = getAmode mem `thenNat` \ amode ->
839 code = amodeCode amode
840 src = amodeAddr amode
841 size = primRepToSize pk
842 code__2 dst = code `snocOL`
843 if pk == DoubleRep || pk == FloatRep
844 then GLD size src dst
846 L -> MOV L (OpAddr src) (OpReg dst)
847 B -> MOVZxL B (OpAddr src) (OpReg dst)
849 returnNat (Any pk code__2)
851 getRegister (StInt i)
853 src = ImmInt (fromInteger i)
856 = unitOL (XOR L (OpReg dst) (OpReg dst))
858 = unitOL (MOV L (OpImm src) (OpReg dst))
860 returnNat (Any IntRep code)
864 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
866 returnNat (Any PtrRep code)
868 = pprPanic "getRegister(x86)" (pprStixTree leaf)
871 imm__2 = case imm of Just x -> x
873 #endif {- i386_TARGET_ARCH -}
874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
875 #if sparc_TARGET_ARCH
877 getRegister (StFloat d)
878 = getNatLabelNCG `thenNat` \ lbl ->
879 getNewRegNCG PtrRep `thenNat` \ tmp ->
880 let code dst = toOL [
885 SETHI (HI (ImmCLbl lbl)) tmp,
886 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
888 returnNat (Any FloatRep code)
890 getRegister (StDouble d)
891 = getNatLabelNCG `thenNat` \ lbl ->
892 getNewRegNCG PtrRep `thenNat` \ tmp ->
893 let code dst = toOL [
896 DATA DF [ImmDouble d],
898 SETHI (HI (ImmCLbl lbl)) tmp,
899 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
901 returnNat (Any DoubleRep code)
903 -- The 6-word scratch area is immediately below the frame pointer.
904 -- Below that is the spill area.
905 getRegister (StScratchWord i)
908 code dst = unitOL (fpRelEA j dst)
910 returnNat (Any PtrRep code)
913 getRegister (StPrim primop [x]) -- unary PrimOps
915 IntNegOp -> trivialUCode (SUB False False g0) x
916 NotOp -> trivialUCode (XNOR False g0) x
918 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
919 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) 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 [fixed_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 -> (False, 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"))
977 -> pprPanic "getRegister(sparc,monadicprimop)"
978 (pprStixTree (StPrim primop [x]))
980 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
982 CharGtOp -> condIntReg GTT x y
983 CharGeOp -> condIntReg GE x y
984 CharEqOp -> condIntReg EQQ x y
985 CharNeOp -> condIntReg NE x y
986 CharLtOp -> condIntReg LTT x y
987 CharLeOp -> condIntReg LE x y
989 IntGtOp -> condIntReg GTT x y
990 IntGeOp -> condIntReg GE x y
991 IntEqOp -> condIntReg EQQ x y
992 IntNeOp -> condIntReg NE x y
993 IntLtOp -> condIntReg LTT x y
994 IntLeOp -> condIntReg LE x y
996 WordGtOp -> condIntReg GU x y
997 WordGeOp -> condIntReg GEU x y
998 WordEqOp -> condIntReg EQQ x y
999 WordNeOp -> condIntReg NE x y
1000 WordLtOp -> condIntReg LU x y
1001 WordLeOp -> condIntReg LEU x y
1003 AddrGtOp -> condIntReg GU x y
1004 AddrGeOp -> condIntReg GEU x y
1005 AddrEqOp -> condIntReg EQQ x y
1006 AddrNeOp -> condIntReg NE x y
1007 AddrLtOp -> condIntReg LU x y
1008 AddrLeOp -> condIntReg LEU x y
1010 FloatGtOp -> condFltReg GTT x y
1011 FloatGeOp -> condFltReg GE x y
1012 FloatEqOp -> condFltReg EQQ x y
1013 FloatNeOp -> condFltReg NE x y
1014 FloatLtOp -> condFltReg LTT x y
1015 FloatLeOp -> condFltReg LE x y
1017 DoubleGtOp -> condFltReg GTT x y
1018 DoubleGeOp -> condFltReg GE x y
1019 DoubleEqOp -> condFltReg EQQ x y
1020 DoubleNeOp -> condFltReg NE x y
1021 DoubleLtOp -> condFltReg LTT x y
1022 DoubleLeOp -> condFltReg LE x y
1024 IntAddOp -> trivialCode (ADD False False) x y
1025 IntSubOp -> trivialCode (SUB False False) x y
1027 -- ToDo: teach about V8+ SPARC mul/div instructions
1028 IntMulOp -> imul_div SLIT(".umul") x y
1029 IntQuotOp -> imul_div SLIT(".div") x y
1030 IntRemOp -> imul_div SLIT(".rem") x y
1032 FloatAddOp -> trivialFCode FloatRep FADD x y
1033 FloatSubOp -> trivialFCode FloatRep FSUB x y
1034 FloatMulOp -> trivialFCode FloatRep FMUL x y
1035 FloatDivOp -> trivialFCode FloatRep FDIV x y
1037 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1038 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1039 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1040 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1042 AndOp -> trivialCode (AND False) x y
1043 OrOp -> trivialCode (OR False) x y
1044 XorOp -> trivialCode (XOR False) x y
1045 SllOp -> trivialCode SLL x y
1046 SrlOp -> trivialCode SRL x y
1048 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1049 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1050 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1052 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1053 [promote x, promote y])
1054 where promote x = StPrim Float2DoubleOp [x]
1055 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1059 -> pprPanic "getRegister(sparc,dyadic primop)"
1060 (pprStixTree (StPrim primop [x, y]))
1063 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1065 getRegister (StInd pk mem)
1066 = getAmode mem `thenNat` \ amode ->
1068 code = amodeCode amode
1069 src = amodeAddr amode
1070 size = primRepToSize pk
1071 code__2 dst = code `snocOL` LD size src dst
1073 returnNat (Any pk code__2)
1075 getRegister (StInt i)
1078 src = ImmInt (fromInteger i)
1079 code dst = unitOL (OR False g0 (RIImm src) dst)
1081 returnNat (Any IntRep code)
1087 SETHI (HI imm__2) dst,
1088 OR False dst (RIImm (LO imm__2)) dst]
1090 returnNat (Any PtrRep code)
1092 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1095 imm__2 = case imm of Just x -> x
1097 #endif {- sparc_TARGET_ARCH -}
1100 %************************************************************************
1102 \subsection{The @Amode@ type}
1104 %************************************************************************
1106 @Amode@s: Memory addressing modes passed up the tree.
1108 data Amode = Amode MachRegsAddr InstrBlock
1110 amodeAddr (Amode addr _) = addr
1111 amodeCode (Amode _ code) = code
1114 Now, given a tree (the argument to an StInd) that references memory,
1115 produce a suitable addressing mode.
1117 A Rule of the Game (tm) for Amodes: use of the addr bit must
1118 immediately follow use of the code part, since the code part puts
1119 values in registers which the addr then refers to. So you can't put
1120 anything in between, lest it overwrite some of those registers. If
1121 you need to do some other computation between the code part and use of
1122 the addr bit, first store the effective address from the amode in a
1123 temporary, then do the other computation, and then use the temporary:
1127 ... other computation ...
1131 getAmode :: StixTree -> NatM Amode
1133 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1135 #if alpha_TARGET_ARCH
1137 getAmode (StPrim IntSubOp [x, StInt i])
1138 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1139 getRegister x `thenNat` \ register ->
1141 code = registerCode register tmp
1142 reg = registerName register tmp
1143 off = ImmInt (-(fromInteger i))
1145 returnNat (Amode (AddrRegImm reg off) code)
1147 getAmode (StPrim IntAddOp [x, StInt i])
1148 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1149 getRegister x `thenNat` \ register ->
1151 code = registerCode register tmp
1152 reg = registerName register tmp
1153 off = ImmInt (fromInteger i)
1155 returnNat (Amode (AddrRegImm reg off) code)
1159 = returnNat (Amode (AddrImm imm__2) id)
1162 imm__2 = case imm of Just x -> x
1165 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1166 getRegister other `thenNat` \ register ->
1168 code = registerCode register tmp
1169 reg = registerName register tmp
1171 returnNat (Amode (AddrReg reg) code)
1173 #endif {- alpha_TARGET_ARCH -}
1174 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1175 #if i386_TARGET_ARCH
1177 getAmode (StPrim IntSubOp [x, StInt i])
1178 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1179 getRegister x `thenNat` \ register ->
1181 code = registerCode register tmp
1182 reg = registerName register tmp
1183 off = ImmInt (-(fromInteger i))
1185 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1187 getAmode (StPrim IntAddOp [x, StInt i])
1189 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1192 imm__2 = case imm of Just x -> x
1194 getAmode (StPrim IntAddOp [x, StInt i])
1195 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1196 getRegister x `thenNat` \ register ->
1198 code = registerCode register tmp
1199 reg = registerName register tmp
1200 off = ImmInt (fromInteger i)
1202 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1204 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1205 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1206 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1207 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1208 getRegister x `thenNat` \ register1 ->
1209 getRegister y `thenNat` \ register2 ->
1211 code1 = registerCode register1 tmp1
1212 reg1 = registerName register1 tmp1
1213 code2 = registerCode register2 tmp2
1214 reg2 = registerName register2 tmp2
1215 code__2 = code1 `appOL` code2
1216 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1218 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1223 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1226 imm__2 = case imm of Just x -> x
1229 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1230 getRegister other `thenNat` \ register ->
1232 code = registerCode register tmp
1233 reg = registerName register tmp
1235 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1237 #endif {- i386_TARGET_ARCH -}
1238 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1239 #if sparc_TARGET_ARCH
1241 getAmode (StPrim IntSubOp [x, StInt i])
1243 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1244 getRegister x `thenNat` \ register ->
1246 code = registerCode register tmp
1247 reg = registerName register tmp
1248 off = ImmInt (-(fromInteger i))
1250 returnNat (Amode (AddrRegImm reg off) code)
1253 getAmode (StPrim IntAddOp [x, StInt i])
1255 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1256 getRegister x `thenNat` \ register ->
1258 code = registerCode register tmp
1259 reg = registerName register tmp
1260 off = ImmInt (fromInteger i)
1262 returnNat (Amode (AddrRegImm reg off) code)
1264 getAmode (StPrim IntAddOp [x, y])
1265 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1266 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1267 getRegister x `thenNat` \ register1 ->
1268 getRegister y `thenNat` \ register2 ->
1270 code1 = registerCode register1 tmp1
1271 reg1 = registerName register1 tmp1
1272 code2 = registerCode register2 tmp2
1273 reg2 = registerName register2 tmp2
1274 code__2 = code1 `appOL` code2
1276 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1280 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1282 code = unitOL (SETHI (HI imm__2) tmp)
1284 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1287 imm__2 = case imm of Just x -> x
1290 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1291 getRegister other `thenNat` \ register ->
1293 code = registerCode register tmp
1294 reg = registerName register tmp
1297 returnNat (Amode (AddrRegImm reg off) code)
1299 #endif {- sparc_TARGET_ARCH -}
1302 %************************************************************************
1304 \subsection{The @CondCode@ type}
1306 %************************************************************************
1308 Condition codes passed up the tree.
1310 data CondCode = CondCode Bool Cond InstrBlock
1312 condName (CondCode _ cond _) = cond
1313 condFloat (CondCode is_float _ _) = is_float
1314 condCode (CondCode _ _ code) = code
1317 Set up a condition code for a conditional branch.
1320 getCondCode :: StixTree -> NatM CondCode
1322 #if alpha_TARGET_ARCH
1323 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1324 #endif {- alpha_TARGET_ARCH -}
1325 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1327 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1328 -- yes, they really do seem to want exactly the same!
1330 getCondCode (StPrim primop [x, y])
1332 CharGtOp -> condIntCode GTT x y
1333 CharGeOp -> condIntCode GE x y
1334 CharEqOp -> condIntCode EQQ x y
1335 CharNeOp -> condIntCode NE x y
1336 CharLtOp -> condIntCode LTT x y
1337 CharLeOp -> condIntCode LE x y
1339 IntGtOp -> condIntCode GTT x y
1340 IntGeOp -> condIntCode GE x y
1341 IntEqOp -> condIntCode EQQ x y
1342 IntNeOp -> condIntCode NE x y
1343 IntLtOp -> condIntCode LTT x y
1344 IntLeOp -> condIntCode LE x y
1346 WordGtOp -> condIntCode GU x y
1347 WordGeOp -> condIntCode GEU x y
1348 WordEqOp -> condIntCode EQQ x y
1349 WordNeOp -> condIntCode NE x y
1350 WordLtOp -> condIntCode LU x y
1351 WordLeOp -> condIntCode LEU x y
1353 AddrGtOp -> condIntCode GU x y
1354 AddrGeOp -> condIntCode GEU x y
1355 AddrEqOp -> condIntCode EQQ x y
1356 AddrNeOp -> condIntCode NE x y
1357 AddrLtOp -> condIntCode LU x y
1358 AddrLeOp -> condIntCode LEU x y
1360 FloatGtOp -> condFltCode GTT x y
1361 FloatGeOp -> condFltCode GE x y
1362 FloatEqOp -> condFltCode EQQ x y
1363 FloatNeOp -> condFltCode NE x y
1364 FloatLtOp -> condFltCode LTT x y
1365 FloatLeOp -> condFltCode LE x y
1367 DoubleGtOp -> condFltCode GTT x y
1368 DoubleGeOp -> condFltCode GE x y
1369 DoubleEqOp -> condFltCode EQQ x y
1370 DoubleNeOp -> condFltCode NE x y
1371 DoubleLtOp -> condFltCode LTT x y
1372 DoubleLeOp -> condFltCode LE x y
1374 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1379 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1380 passed back up the tree.
1383 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1385 #if alpha_TARGET_ARCH
1386 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1387 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1388 #endif {- alpha_TARGET_ARCH -}
1390 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1391 #if i386_TARGET_ARCH
1393 -- memory vs immediate
1394 condIntCode cond (StInd pk x) y
1396 = getAmode x `thenNat` \ amode ->
1398 code1 = amodeCode amode
1399 x__2 = amodeAddr amode
1400 sz = primRepToSize pk
1401 code__2 = code1 `snocOL`
1402 CMP sz (OpImm imm__2) (OpAddr x__2)
1404 returnNat (CondCode False cond code__2)
1407 imm__2 = case imm of Just x -> x
1410 condIntCode cond x (StInt 0)
1411 = getRegister x `thenNat` \ register1 ->
1412 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1414 code1 = registerCode register1 tmp1
1415 src1 = registerName register1 tmp1
1416 code__2 = code1 `snocOL`
1417 TEST L (OpReg src1) (OpReg src1)
1419 returnNat (CondCode False cond code__2)
1421 -- anything vs immediate
1422 condIntCode cond x y
1424 = getRegister x `thenNat` \ register1 ->
1425 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1427 code1 = registerCode register1 tmp1
1428 src1 = registerName register1 tmp1
1429 code__2 = code1 `snocOL`
1430 CMP L (OpImm imm__2) (OpReg src1)
1432 returnNat (CondCode False cond code__2)
1435 imm__2 = case imm of Just x -> x
1437 -- memory vs anything
1438 condIntCode cond (StInd pk x) y
1439 = getAmode x `thenNat` \ amode_x ->
1440 getRegister y `thenNat` \ reg_y ->
1441 getNewRegNCG IntRep `thenNat` \ tmp ->
1443 c_x = amodeCode amode_x
1444 am_x = amodeAddr amode_x
1445 c_y = registerCode reg_y tmp
1446 r_y = registerName reg_y tmp
1447 sz = primRepToSize pk
1449 -- optimisation: if there's no code for x, just an amode,
1450 -- use whatever reg y winds up in. Assumes that c_y doesn't
1451 -- clobber any regs in the amode am_x, which I'm not sure is
1452 -- justified. The otherwise clause makes the same assumption.
1453 code__2 | isNilOL c_x
1455 CMP sz (OpReg r_y) (OpAddr am_x)
1459 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1461 CMP sz (OpReg tmp) (OpAddr am_x)
1463 returnNat (CondCode False cond code__2)
1465 -- anything vs memory
1467 condIntCode cond y (StInd pk x)
1468 = getAmode x `thenNat` \ amode_x ->
1469 getRegister y `thenNat` \ reg_y ->
1470 getNewRegNCG IntRep `thenNat` \ tmp ->
1472 c_x = amodeCode amode_x
1473 am_x = amodeAddr amode_x
1474 c_y = registerCode reg_y tmp
1475 r_y = registerName reg_y tmp
1476 sz = primRepToSize pk
1477 -- same optimisation and nagging doubts as previous clause
1478 code__2 | isNilOL c_x
1480 CMP sz (OpAddr am_x) (OpReg r_y)
1484 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1486 CMP sz (OpAddr am_x) (OpReg tmp)
1488 returnNat (CondCode False cond code__2)
1490 -- anything vs anything
1491 condIntCode cond x y
1492 = getRegister x `thenNat` \ register1 ->
1493 getRegister y `thenNat` \ register2 ->
1494 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1495 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1497 code1 = registerCode register1 tmp1
1498 src1 = registerName register1 tmp1
1499 code2 = registerCode register2 tmp2
1500 src2 = registerName register2 tmp2
1501 code__2 = code1 `snocOL`
1502 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1504 CMP L (OpReg src2) (OpReg tmp1)
1506 returnNat (CondCode False cond code__2)
1509 condFltCode cond x y
1510 = getRegister x `thenNat` \ register1 ->
1511 getRegister y `thenNat` \ register2 ->
1512 getNewRegNCG (registerRep register1)
1514 getNewRegNCG (registerRep register2)
1516 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1518 pk1 = registerRep register1
1519 code1 = registerCode register1 tmp1
1520 src1 = registerName register1 tmp1
1522 code2 = registerCode register2 tmp2
1523 src2 = registerName register2 tmp2
1525 code__2 | isAny register1
1526 = code1 `appOL` -- result in tmp1
1528 GCMP (primRepToSize pk1) tmp1 src2
1532 GMOV src1 tmp1 `appOL`
1534 GCMP (primRepToSize pk1) tmp1 src2
1536 {- On the 486, the flags set by FP compare are the unsigned ones!
1537 (This looks like a HACK to me. WDP 96/03)
1539 fix_FP_cond :: Cond -> Cond
1541 fix_FP_cond GE = GEU
1542 fix_FP_cond GTT = GU
1543 fix_FP_cond LTT = LU
1544 fix_FP_cond LE = LEU
1545 fix_FP_cond any = any
1547 returnNat (CondCode True (fix_FP_cond cond) code__2)
1551 #endif {- i386_TARGET_ARCH -}
1552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1553 #if sparc_TARGET_ARCH
1555 condIntCode cond x (StInt y)
1557 = getRegister x `thenNat` \ register ->
1558 getNewRegNCG IntRep `thenNat` \ tmp ->
1560 code = registerCode register tmp
1561 src1 = registerName register tmp
1562 src2 = ImmInt (fromInteger y)
1563 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1565 returnNat (CondCode False cond code__2)
1567 condIntCode cond x y
1568 = getRegister x `thenNat` \ register1 ->
1569 getRegister y `thenNat` \ register2 ->
1570 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1571 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1573 code1 = registerCode register1 tmp1
1574 src1 = registerName register1 tmp1
1575 code2 = registerCode register2 tmp2
1576 src2 = registerName register2 tmp2
1577 code__2 = code1 `appOL` code2 `snocOL`
1578 SUB False True src1 (RIReg src2) g0
1580 returnNat (CondCode False cond code__2)
1583 condFltCode cond x y
1584 = getRegister x `thenNat` \ register1 ->
1585 getRegister y `thenNat` \ register2 ->
1586 getNewRegNCG (registerRep register1)
1588 getNewRegNCG (registerRep register2)
1590 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1592 promote x = FxTOy F DF x tmp
1594 pk1 = registerRep register1
1595 code1 = registerCode register1 tmp1
1596 src1 = registerName register1 tmp1
1598 pk2 = registerRep register2
1599 code2 = registerCode register2 tmp2
1600 src2 = registerName register2 tmp2
1604 code1 `appOL` code2 `snocOL`
1605 FCMP True (primRepToSize pk1) src1 src2
1606 else if pk1 == FloatRep then
1607 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1608 FCMP True DF tmp src2
1610 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1611 FCMP True DF src1 tmp
1613 returnNat (CondCode True cond code__2)
1615 #endif {- sparc_TARGET_ARCH -}
1618 %************************************************************************
1620 \subsection{Generating assignments}
1622 %************************************************************************
1624 Assignments are really at the heart of the whole code generation
1625 business. Almost all top-level nodes of any real importance are
1626 assignments, which correspond to loads, stores, or register transfers.
1627 If we're really lucky, some of the register transfers will go away,
1628 because we can use the destination register to complete the code
1629 generation for the right hand side. This only fails when the right
1630 hand side is forced into a fixed register (e.g. the result of a call).
1633 assignIntCode, assignFltCode
1634 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1636 #if alpha_TARGET_ARCH
1638 assignIntCode pk (StInd _ dst) src
1639 = getNewRegNCG IntRep `thenNat` \ tmp ->
1640 getAmode dst `thenNat` \ amode ->
1641 getRegister src `thenNat` \ register ->
1643 code1 = amodeCode amode []
1644 dst__2 = amodeAddr amode
1645 code2 = registerCode register tmp []
1646 src__2 = registerName register tmp
1647 sz = primRepToSize pk
1648 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1652 assignIntCode pk dst src
1653 = getRegister dst `thenNat` \ register1 ->
1654 getRegister src `thenNat` \ register2 ->
1656 dst__2 = registerName register1 zeroh
1657 code = registerCode register2 dst__2
1658 src__2 = registerName register2 dst__2
1659 code__2 = if isFixed register2
1660 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1665 #endif {- alpha_TARGET_ARCH -}
1666 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1667 #if i386_TARGET_ARCH
1669 -- Destination of an assignment can only be reg or mem.
1670 -- This is the mem case.
1671 assignIntCode pk (StInd _ dst) src
1672 = getAmode dst `thenNat` \ amode ->
1673 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1674 getNewRegNCG PtrRep `thenNat` \ tmp ->
1676 -- In general, if the address computation for dst may require
1677 -- some insns preceding the addressing mode itself. So there's
1678 -- no guarantee that the code for dst and the code for src won't
1679 -- write the same register. This means either the address or
1680 -- the value needs to be copied into a temporary. We detect the
1681 -- common case where the amode has no code, and elide the copy.
1682 codea = amodeCode amode
1683 dst__a = amodeAddr amode
1685 code | isNilOL codea
1687 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1691 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1693 MOV (primRepToSize pk) opsrc
1694 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1700 -> NatM (InstrBlock,Operand) -- code, operator
1704 = returnNat (nilOL, OpImm imm_op)
1707 imm_op = case imm of Just x -> x
1710 = getRegister op `thenNat` \ register ->
1711 getNewRegNCG (registerRep register)
1713 let code = registerCode register tmp
1714 reg = registerName register tmp
1716 returnNat (code, OpReg reg)
1718 -- Assign; dst is a reg, rhs is mem
1719 assignIntCode pk dst (StInd pks src)
1720 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1721 getAmode src `thenNat` \ amode ->
1722 getRegister dst `thenNat` \ reg_dst ->
1724 c_addr = amodeCode amode
1725 am_addr = amodeAddr amode
1727 c_dst = registerCode reg_dst tmp -- should be empty
1728 r_dst = registerName reg_dst tmp
1729 szs = primRepToSize pks
1730 opc = case szs of L -> MOV L ; B -> MOVZxL B
1732 code | isNilOL c_dst
1734 opc (OpAddr am_addr) (OpReg r_dst)
1736 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1740 -- dst is a reg, but src could be anything
1741 assignIntCode pk dst src
1742 = getRegister dst `thenNat` \ registerd ->
1743 getRegister src `thenNat` \ registers ->
1744 getNewRegNCG IntRep `thenNat` \ tmp ->
1746 r_dst = registerName registerd tmp
1747 c_dst = registerCode registerd tmp -- should be empty
1748 r_src = registerName registers r_dst
1749 c_src = registerCode registers r_dst
1751 code | isNilOL c_dst
1753 MOV L (OpReg r_src) (OpReg r_dst)
1755 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1759 #endif {- i386_TARGET_ARCH -}
1760 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1761 #if sparc_TARGET_ARCH
1763 assignIntCode pk (StInd _ dst) src
1764 = getNewRegNCG IntRep `thenNat` \ tmp ->
1765 getAmode dst `thenNat` \ amode ->
1766 getRegister src `thenNat` \ register ->
1768 code1 = amodeCode amode
1769 dst__2 = amodeAddr amode
1770 code2 = registerCode register tmp
1771 src__2 = registerName register tmp
1772 sz = primRepToSize pk
1773 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1777 assignIntCode pk dst src
1778 = getRegister dst `thenNat` \ register1 ->
1779 getRegister src `thenNat` \ register2 ->
1781 dst__2 = registerName register1 g0
1782 code = registerCode register2 dst__2
1783 src__2 = registerName register2 dst__2
1784 code__2 = if isFixed register2
1785 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1790 #endif {- sparc_TARGET_ARCH -}
1793 % --------------------------------
1794 Floating-point assignments:
1795 % --------------------------------
1797 #if alpha_TARGET_ARCH
1799 assignFltCode pk (StInd _ dst) src
1800 = getNewRegNCG pk `thenNat` \ tmp ->
1801 getAmode dst `thenNat` \ amode ->
1802 getRegister src `thenNat` \ register ->
1804 code1 = amodeCode amode []
1805 dst__2 = amodeAddr amode
1806 code2 = registerCode register tmp []
1807 src__2 = registerName register tmp
1808 sz = primRepToSize pk
1809 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1813 assignFltCode pk dst src
1814 = getRegister dst `thenNat` \ register1 ->
1815 getRegister src `thenNat` \ register2 ->
1817 dst__2 = registerName register1 zeroh
1818 code = registerCode register2 dst__2
1819 src__2 = registerName register2 dst__2
1820 code__2 = if isFixed register2
1821 then code . mkSeqInstr (FMOV src__2 dst__2)
1826 #endif {- alpha_TARGET_ARCH -}
1827 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1828 #if i386_TARGET_ARCH
1831 assignFltCode pk (StInd pk_dst addr) src
1833 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1835 = getRegister src `thenNat` \ reg_src ->
1836 getRegister addr `thenNat` \ reg_addr ->
1837 getNewRegNCG pk `thenNat` \ tmp_src ->
1838 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1839 let r_src = registerName reg_src tmp_src
1840 c_src = registerCode reg_src tmp_src
1841 r_addr = registerName reg_addr tmp_addr
1842 c_addr = registerCode reg_addr tmp_addr
1843 sz = primRepToSize pk
1845 code = c_src `appOL`
1846 -- no need to preserve r_src across the addr computation,
1847 -- since r_src must be a float reg
1848 -- whilst r_addr is an int reg
1851 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1855 -- dst must be a (FP) register
1856 assignFltCode pk dst src
1857 = getRegister dst `thenNat` \ reg_dst ->
1858 getRegister src `thenNat` \ reg_src ->
1859 getNewRegNCG pk `thenNat` \ tmp ->
1861 r_dst = registerName reg_dst tmp
1862 c_dst = registerCode reg_dst tmp -- should be empty
1864 r_src = registerName reg_src r_dst
1865 c_src = registerCode reg_src r_dst
1867 code | isNilOL c_dst
1868 = if isFixed reg_src
1869 then c_src `snocOL` GMOV r_src r_dst
1872 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1878 #endif {- i386_TARGET_ARCH -}
1879 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1880 #if sparc_TARGET_ARCH
1882 assignFltCode pk (StInd _ dst) src
1883 = getNewRegNCG pk `thenNat` \ tmp1 ->
1884 getAmode dst `thenNat` \ amode ->
1885 getRegister src `thenNat` \ register ->
1887 sz = primRepToSize pk
1888 dst__2 = amodeAddr amode
1890 code1 = amodeCode amode
1891 code2 = registerCode register tmp1
1893 src__2 = registerName register tmp1
1894 pk__2 = registerRep register
1895 sz__2 = primRepToSize pk__2
1897 code__2 = code1 `appOL` code2 `appOL`
1899 then unitOL (ST sz src__2 dst__2)
1900 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1904 assignFltCode pk dst src
1905 = getRegister dst `thenNat` \ register1 ->
1906 getRegister src `thenNat` \ register2 ->
1908 pk__2 = registerRep register2
1909 sz__2 = primRepToSize pk__2
1911 getNewRegNCG pk__2 `thenNat` \ tmp ->
1913 sz = primRepToSize pk
1914 dst__2 = registerName register1 g0 -- must be Fixed
1917 reg__2 = if pk /= pk__2 then tmp else dst__2
1919 code = registerCode register2 reg__2
1921 src__2 = registerName register2 reg__2
1925 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1926 else if isFixed register2 then
1927 code `snocOL` FMOV sz src__2 dst__2
1933 #endif {- sparc_TARGET_ARCH -}
1936 %************************************************************************
1938 \subsection{Generating an unconditional branch}
1940 %************************************************************************
1942 We accept two types of targets: an immediate CLabel or a tree that
1943 gets evaluated into a register. Any CLabels which are AsmTemporaries
1944 are assumed to be in the local block of code, close enough for a
1945 branch instruction. Other CLabels are assumed to be far away.
1947 (If applicable) Do not fill the delay slots here; you will confuse the
1951 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
1953 #if alpha_TARGET_ARCH
1955 genJump (StCLbl lbl)
1956 | isAsmTemp lbl = returnInstr (BR target)
1957 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1959 target = ImmCLbl lbl
1962 = getRegister tree `thenNat` \ register ->
1963 getNewRegNCG PtrRep `thenNat` \ tmp ->
1965 dst = registerName register pv
1966 code = registerCode register pv
1967 target = registerName register pv
1969 if isFixed register then
1970 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1972 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1974 #endif {- alpha_TARGET_ARCH -}
1975 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1976 #if i386_TARGET_ARCH
1978 genJump dsts (StInd pk mem)
1979 = getAmode mem `thenNat` \ amode ->
1981 code = amodeCode amode
1982 target = amodeAddr amode
1984 returnNat (code `snocOL` JMP dsts (OpAddr target))
1988 = returnNat (unitOL (JMP dsts (OpImm target)))
1991 = getRegister tree `thenNat` \ register ->
1992 getNewRegNCG PtrRep `thenNat` \ tmp ->
1994 code = registerCode register tmp
1995 target = registerName register tmp
1997 returnNat (code `snocOL` JMP dsts (OpReg target))
2000 target = case imm of Just x -> x
2002 #endif {- i386_TARGET_ARCH -}
2003 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2004 #if sparc_TARGET_ARCH
2006 genJump dsts (StCLbl lbl)
2007 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2008 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2009 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2011 target = ImmCLbl lbl
2014 = getRegister tree `thenNat` \ register ->
2015 getNewRegNCG PtrRep `thenNat` \ tmp ->
2017 code = registerCode register tmp
2018 target = registerName register tmp
2020 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2022 #endif {- sparc_TARGET_ARCH -}
2025 %************************************************************************
2027 \subsection{Conditional jumps}
2029 %************************************************************************
2031 Conditional jumps are always to local labels, so we can use branch
2032 instructions. We peek at the arguments to decide what kind of
2035 ALPHA: For comparisons with 0, we're laughing, because we can just do
2036 the desired conditional branch.
2038 I386: First, we have to ensure that the condition
2039 codes are set according to the supplied comparison operation.
2041 SPARC: First, we have to ensure that the condition codes are set
2042 according to the supplied comparison operation. We generate slightly
2043 different code for floating point comparisons, because a floating
2044 point operation cannot directly precede a @BF@. We assume the worst
2045 and fill that slot with a @NOP@.
2047 SPARC: Do not fill the delay slots here; you will confuse the register
2052 :: CLabel -- the branch target
2053 -> StixTree -- the condition on which to branch
2056 #if alpha_TARGET_ARCH
2058 genCondJump lbl (StPrim op [x, StInt 0])
2059 = getRegister x `thenNat` \ register ->
2060 getNewRegNCG (registerRep register)
2063 code = registerCode register tmp
2064 value = registerName register tmp
2065 pk = registerRep register
2066 target = ImmCLbl lbl
2068 returnSeq code [BI (cmpOp op) value target]
2070 cmpOp CharGtOp = GTT
2072 cmpOp CharEqOp = EQQ
2074 cmpOp CharLtOp = LTT
2083 cmpOp WordGeOp = ALWAYS
2084 cmpOp WordEqOp = EQQ
2086 cmpOp WordLtOp = NEVER
2087 cmpOp WordLeOp = EQQ
2089 cmpOp AddrGeOp = ALWAYS
2090 cmpOp AddrEqOp = EQQ
2092 cmpOp AddrLtOp = NEVER
2093 cmpOp AddrLeOp = EQQ
2095 genCondJump lbl (StPrim op [x, StDouble 0.0])
2096 = getRegister x `thenNat` \ register ->
2097 getNewRegNCG (registerRep register)
2100 code = registerCode register tmp
2101 value = registerName register tmp
2102 pk = registerRep register
2103 target = ImmCLbl lbl
2105 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2107 cmpOp FloatGtOp = GTT
2108 cmpOp FloatGeOp = GE
2109 cmpOp FloatEqOp = EQQ
2110 cmpOp FloatNeOp = NE
2111 cmpOp FloatLtOp = LTT
2112 cmpOp FloatLeOp = LE
2113 cmpOp DoubleGtOp = GTT
2114 cmpOp DoubleGeOp = GE
2115 cmpOp DoubleEqOp = EQQ
2116 cmpOp DoubleNeOp = NE
2117 cmpOp DoubleLtOp = LTT
2118 cmpOp DoubleLeOp = LE
2120 genCondJump lbl (StPrim op [x, y])
2122 = trivialFCode pr instr x y `thenNat` \ register ->
2123 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2125 code = registerCode register tmp
2126 result = registerName register tmp
2127 target = ImmCLbl lbl
2129 returnNat (code . mkSeqInstr (BF cond result target))
2131 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2133 fltCmpOp op = case op of
2147 (instr, cond) = case op of
2148 FloatGtOp -> (FCMP TF LE, EQQ)
2149 FloatGeOp -> (FCMP TF LTT, EQQ)
2150 FloatEqOp -> (FCMP TF EQQ, NE)
2151 FloatNeOp -> (FCMP TF EQQ, EQQ)
2152 FloatLtOp -> (FCMP TF LTT, NE)
2153 FloatLeOp -> (FCMP TF LE, NE)
2154 DoubleGtOp -> (FCMP TF LE, EQQ)
2155 DoubleGeOp -> (FCMP TF LTT, EQQ)
2156 DoubleEqOp -> (FCMP TF EQQ, NE)
2157 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2158 DoubleLtOp -> (FCMP TF LTT, NE)
2159 DoubleLeOp -> (FCMP TF LE, NE)
2161 genCondJump lbl (StPrim op [x, y])
2162 = trivialCode instr x y `thenNat` \ register ->
2163 getNewRegNCG IntRep `thenNat` \ tmp ->
2165 code = registerCode register tmp
2166 result = registerName register tmp
2167 target = ImmCLbl lbl
2169 returnNat (code . mkSeqInstr (BI cond result target))
2171 (instr, cond) = case op of
2172 CharGtOp -> (CMP LE, EQQ)
2173 CharGeOp -> (CMP LTT, EQQ)
2174 CharEqOp -> (CMP EQQ, NE)
2175 CharNeOp -> (CMP EQQ, EQQ)
2176 CharLtOp -> (CMP LTT, NE)
2177 CharLeOp -> (CMP LE, NE)
2178 IntGtOp -> (CMP LE, EQQ)
2179 IntGeOp -> (CMP LTT, EQQ)
2180 IntEqOp -> (CMP EQQ, NE)
2181 IntNeOp -> (CMP EQQ, EQQ)
2182 IntLtOp -> (CMP LTT, NE)
2183 IntLeOp -> (CMP LE, NE)
2184 WordGtOp -> (CMP ULE, EQQ)
2185 WordGeOp -> (CMP ULT, EQQ)
2186 WordEqOp -> (CMP EQQ, NE)
2187 WordNeOp -> (CMP EQQ, EQQ)
2188 WordLtOp -> (CMP ULT, NE)
2189 WordLeOp -> (CMP ULE, NE)
2190 AddrGtOp -> (CMP ULE, EQQ)
2191 AddrGeOp -> (CMP ULT, EQQ)
2192 AddrEqOp -> (CMP EQQ, NE)
2193 AddrNeOp -> (CMP EQQ, EQQ)
2194 AddrLtOp -> (CMP ULT, NE)
2195 AddrLeOp -> (CMP ULE, NE)
2197 #endif {- alpha_TARGET_ARCH -}
2198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2199 #if i386_TARGET_ARCH
2201 genCondJump lbl bool
2202 = getCondCode bool `thenNat` \ condition ->
2204 code = condCode condition
2205 cond = condName condition
2207 returnNat (code `snocOL` JXX cond lbl)
2209 #endif {- i386_TARGET_ARCH -}
2210 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2211 #if sparc_TARGET_ARCH
2213 genCondJump lbl bool
2214 = getCondCode bool `thenNat` \ condition ->
2216 code = condCode condition
2217 cond = condName condition
2218 target = ImmCLbl lbl
2223 if condFloat condition
2224 then [NOP, BF cond False target, NOP]
2225 else [BI cond False target, NOP]
2229 #endif {- sparc_TARGET_ARCH -}
2232 %************************************************************************
2234 \subsection{Generating C calls}
2236 %************************************************************************
2238 Now the biggest nightmare---calls. Most of the nastiness is buried in
2239 @get_arg@, which moves the arguments to the correct registers/stack
2240 locations. Apart from that, the code is easy.
2242 (If applicable) Do not fill the delay slots here; you will confuse the
2247 :: FAST_STRING -- function to call
2249 -> PrimRep -- type of the result
2250 -> [StixTree] -- arguments (of mixed type)
2253 #if alpha_TARGET_ARCH
2255 genCCall fn cconv kind args
2256 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2257 `thenNat` \ ((unused,_), argCode) ->
2259 nRegs = length allArgRegs - length unused
2260 code = asmSeqThen (map ($ []) argCode)
2263 LDA pv (AddrImm (ImmLab (ptext fn))),
2264 JSR ra (AddrReg pv) nRegs,
2265 LDGP gp (AddrReg ra)]
2267 ------------------------
2268 {- Try to get a value into a specific register (or registers) for
2269 a call. The first 6 arguments go into the appropriate
2270 argument register (separate registers for integer and floating
2271 point arguments, but used in lock-step), and the remaining
2272 arguments are dumped to the stack, beginning at 0(sp). Our
2273 first argument is a pair of the list of remaining argument
2274 registers to be assigned for this call and the next stack
2275 offset to use for overflowing arguments. This way,
2276 @get_Arg@ can be applied to all of a call's arguments using
2280 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2281 -> StixTree -- Current argument
2282 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2284 -- We have to use up all of our argument registers first...
2286 get_arg ((iDst,fDst):dsts, offset) arg
2287 = getRegister arg `thenNat` \ register ->
2289 reg = if isFloatingRep pk then fDst else iDst
2290 code = registerCode register reg
2291 src = registerName register reg
2292 pk = registerRep register
2295 if isFloatingRep pk then
2296 ((dsts, offset), if isFixed register then
2297 code . mkSeqInstr (FMOV src fDst)
2300 ((dsts, offset), if isFixed register then
2301 code . mkSeqInstr (OR src (RIReg src) iDst)
2304 -- Once we have run out of argument registers, we move to the
2307 get_arg ([], offset) arg
2308 = getRegister arg `thenNat` \ register ->
2309 getNewRegNCG (registerRep register)
2312 code = registerCode register tmp
2313 src = registerName register tmp
2314 pk = registerRep register
2315 sz = primRepToSize pk
2317 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2319 #endif {- alpha_TARGET_ARCH -}
2320 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2321 #if i386_TARGET_ARCH
2323 genCCall fn cconv kind [StInt i]
2324 | fn == SLIT ("PerformGC_wrapper")
2326 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2327 CALL (ImmLit (ptext (if underscorePrefix
2328 then (SLIT ("_PerformGC_wrapper"))
2329 else (SLIT ("PerformGC_wrapper")))))
2335 genCCall fn cconv kind args
2336 = mapNat get_call_arg
2337 (reverse args) `thenNat` \ sizes_n_codes ->
2338 getDeltaNat `thenNat` \ delta ->
2339 let (sizes, codes) = unzip sizes_n_codes
2340 tot_arg_size = sum sizes
2341 code2 = concatOL codes
2343 [CALL (fn__2 tot_arg_size)]
2345 (if cconv == stdCallConv then [] else
2346 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2348 [DELTA (delta + tot_arg_size)]
2351 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2352 returnNat (code2 `appOL` call)
2355 -- function names that begin with '.' are assumed to be special
2356 -- internally generated names like '.mul,' which don't get an
2357 -- underscore prefix
2358 -- ToDo:needed (WDP 96/03) ???
2362 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2364 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2366 stdcallsize tot_arg_size
2367 | cconv == stdCallConv = '@':show tot_arg_size
2375 get_call_arg :: StixTree{-current argument-}
2376 -> NatM (Int, InstrBlock) -- argsz, code
2379 = get_op arg `thenNat` \ (code, reg, sz) ->
2380 getDeltaNat `thenNat` \ delta ->
2381 arg_size sz `bind` \ size ->
2382 setDeltaNat (delta-size) `thenNat` \ _ ->
2383 if (case sz of DF -> True; F -> True; _ -> False)
2384 then returnNat (size,
2386 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2388 GST sz reg (AddrBaseIndex (Just esp)
2392 else returnNat (size,
2394 PUSH L (OpReg reg) `snocOL`
2400 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2403 = getRegister op `thenNat` \ register ->
2404 getNewRegNCG (registerRep register)
2407 code = registerCode register tmp
2408 reg = registerName register tmp
2409 pk = registerRep register
2410 sz = primRepToSize pk
2412 returnNat (code, reg, sz)
2414 #endif {- i386_TARGET_ARCH -}
2415 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2416 #if sparc_TARGET_ARCH
2418 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.)
2423 If we have to put args on the stack, move %o6==%sp down by
2424 the number of words to go on the stack, to ensure there's enough space.
2426 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2427 16 words above the stack pointer is a word for the address of
2428 a structure return value. I use this as a temporary location
2429 for moving values from float to int regs. Certainly it isn't
2430 safe to put anything in the 16 words starting at %sp, since
2431 this area can get trashed at any time due to window overflows
2432 caused by signal handlers.
2434 A final complication (if the above isn't enough) is that
2435 we can't blithely calculate the arguments one by one into
2436 %o0 .. %o5. Consider the following nested calls:
2440 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2441 the inner call will itself use %o0, which trashes the value put there
2442 in preparation for the outer call. Upshot: we need to calculate the
2443 args into temporary regs, and move those to arg regs or onto the
2444 stack only immediately prior to the call proper. Sigh.
2447 genCCall fn cconv kind args
2448 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2449 let (argcodes, vregss) = unzip argcode_and_vregs
2450 argcode = concatOL argcodes
2451 vregs = concat vregss
2452 n_argRegs = length allArgRegs
2453 n_argRegs_used = min (length vregs) n_argRegs
2454 (move_sp_down, move_sp_up)
2455 = let nn = length vregs - n_argRegs
2456 + 1 -- (for the road)
2459 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2461 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2463 = unitOL (CALL fn__2 n_argRegs_used False)
2465 returnNat (argcode `appOL`
2466 move_sp_down `appOL`
2467 transfer_code `appOL`
2472 -- function names that begin with '.' are assumed to be special
2473 -- internally generated names like '.mul,' which don't get an
2474 -- underscore prefix
2475 -- ToDo:needed (WDP 96/03) ???
2476 fn__2 = case (_HEAD_ fn) of
2477 '.' -> ImmLit (ptext fn)
2478 _ -> ImmLab False (ptext fn)
2480 -- move args from the integer vregs into which they have been
2481 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2482 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2484 move_final [] _ offset -- all args done
2487 move_final (v:vs) [] offset -- out of aregs; move to stack
2488 = ST W v (spRel offset)
2489 : move_final vs [] (offset+1)
2491 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2492 = OR False g0 (RIReg v) a
2493 : move_final vs az offset
2495 -- generate code to calculate an argument, and move it into one
2496 -- or two integer vregs.
2497 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2498 arg_to_int_vregs arg
2499 = getRegister arg `thenNat` \ register ->
2500 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2501 let code = registerCode register tmp
2502 src = registerName register tmp
2503 pk = registerRep register
2505 -- the value is in src. Get it into 1 or 2 int vregs.
2508 getNewRegNCG WordRep `thenNat` \ v1 ->
2509 getNewRegNCG WordRep `thenNat` \ v2 ->
2512 FMOV DF src f0 `snocOL`
2513 ST F f0 (spRel 16) `snocOL`
2514 LD W (spRel 16) v1 `snocOL`
2515 ST F (fPair f0) (spRel 16) `snocOL`
2521 getNewRegNCG WordRep `thenNat` \ v1 ->
2524 ST F src (spRel 16) `snocOL`
2530 getNewRegNCG WordRep `thenNat` \ v1 ->
2532 code `snocOL` OR False g0 (RIReg src) v1
2536 #endif {- sparc_TARGET_ARCH -}
2539 %************************************************************************
2541 \subsection{Support bits}
2543 %************************************************************************
2545 %************************************************************************
2547 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2549 %************************************************************************
2551 Turn those condition codes into integers now (when they appear on
2552 the right hand side of an assignment).
2554 (If applicable) Do not fill the delay slots here; you will confuse the
2558 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2560 #if alpha_TARGET_ARCH
2561 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2562 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2563 #endif {- alpha_TARGET_ARCH -}
2565 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2566 #if i386_TARGET_ARCH
2569 = condIntCode cond x y `thenNat` \ condition ->
2570 getNewRegNCG IntRep `thenNat` \ tmp ->
2572 code = condCode condition
2573 cond = condName condition
2574 code__2 dst = code `appOL` toOL [
2575 SETCC cond (OpReg tmp),
2576 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2577 MOV L (OpReg tmp) (OpReg dst)]
2579 returnNat (Any IntRep code__2)
2582 = getNatLabelNCG `thenNat` \ lbl1 ->
2583 getNatLabelNCG `thenNat` \ lbl2 ->
2584 condFltCode cond x y `thenNat` \ condition ->
2586 code = condCode condition
2587 cond = condName condition
2588 code__2 dst = code `appOL` toOL [
2590 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2593 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2596 returnNat (Any IntRep code__2)
2598 #endif {- i386_TARGET_ARCH -}
2599 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2600 #if sparc_TARGET_ARCH
2602 condIntReg EQQ x (StInt 0)
2603 = getRegister x `thenNat` \ register ->
2604 getNewRegNCG IntRep `thenNat` \ tmp ->
2606 code = registerCode register tmp
2607 src = registerName register tmp
2608 code__2 dst = code `appOL` toOL [
2609 SUB False True g0 (RIReg src) g0,
2610 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2612 returnNat (Any IntRep code__2)
2615 = getRegister x `thenNat` \ register1 ->
2616 getRegister y `thenNat` \ register2 ->
2617 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2618 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2620 code1 = registerCode register1 tmp1
2621 src1 = registerName register1 tmp1
2622 code2 = registerCode register2 tmp2
2623 src2 = registerName register2 tmp2
2624 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2625 XOR False src1 (RIReg src2) dst,
2626 SUB False True g0 (RIReg dst) g0,
2627 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2629 returnNat (Any IntRep code__2)
2631 condIntReg NE x (StInt 0)
2632 = getRegister x `thenNat` \ register ->
2633 getNewRegNCG IntRep `thenNat` \ tmp ->
2635 code = registerCode register tmp
2636 src = registerName register tmp
2637 code__2 dst = code `appOL` toOL [
2638 SUB False True g0 (RIReg src) g0,
2639 ADD True False g0 (RIImm (ImmInt 0)) dst]
2641 returnNat (Any IntRep code__2)
2644 = getRegister x `thenNat` \ register1 ->
2645 getRegister y `thenNat` \ register2 ->
2646 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2647 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2649 code1 = registerCode register1 tmp1
2650 src1 = registerName register1 tmp1
2651 code2 = registerCode register2 tmp2
2652 src2 = registerName register2 tmp2
2653 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2654 XOR False src1 (RIReg src2) dst,
2655 SUB False True g0 (RIReg dst) g0,
2656 ADD True False g0 (RIImm (ImmInt 0)) dst]
2658 returnNat (Any IntRep code__2)
2661 = getNatLabelNCG `thenNat` \ lbl1 ->
2662 getNatLabelNCG `thenNat` \ lbl2 ->
2663 condIntCode cond x y `thenNat` \ condition ->
2665 code = condCode condition
2666 cond = condName condition
2667 code__2 dst = code `appOL` toOL [
2668 BI cond False (ImmCLbl lbl1), NOP,
2669 OR False g0 (RIImm (ImmInt 0)) dst,
2670 BI ALWAYS False (ImmCLbl lbl2), NOP,
2672 OR False g0 (RIImm (ImmInt 1)) dst,
2675 returnNat (Any IntRep code__2)
2678 = getNatLabelNCG `thenNat` \ lbl1 ->
2679 getNatLabelNCG `thenNat` \ lbl2 ->
2680 condFltCode cond x y `thenNat` \ condition ->
2682 code = condCode condition
2683 cond = condName condition
2684 code__2 dst = code `appOL` toOL [
2686 BF cond False (ImmCLbl lbl1), NOP,
2687 OR False g0 (RIImm (ImmInt 0)) dst,
2688 BI ALWAYS False (ImmCLbl lbl2), NOP,
2690 OR False g0 (RIImm (ImmInt 1)) dst,
2693 returnNat (Any IntRep code__2)
2695 #endif {- sparc_TARGET_ARCH -}
2698 %************************************************************************
2700 \subsubsection{@trivial*Code@: deal with trivial instructions}
2702 %************************************************************************
2704 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2705 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2706 for constants on the right hand side, because that's where the generic
2707 optimizer will have put them.
2709 Similarly, for unary instructions, we don't have to worry about
2710 matching an StInt as the argument, because genericOpt will already
2711 have handled the constant-folding.
2715 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2716 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2717 -> Maybe (Operand -> Operand -> Instr)
2718 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2720 -> StixTree -> StixTree -- the two arguments
2725 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2726 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2727 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2729 -> StixTree -> StixTree -- the two arguments
2733 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2734 ,IF_ARCH_i386 ((Operand -> Instr)
2735 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2737 -> StixTree -- the one argument
2742 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2743 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2744 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2746 -> StixTree -- the one argument
2749 #if alpha_TARGET_ARCH
2751 trivialCode instr x (StInt y)
2753 = getRegister x `thenNat` \ register ->
2754 getNewRegNCG IntRep `thenNat` \ tmp ->
2756 code = registerCode register tmp
2757 src1 = registerName register tmp
2758 src2 = ImmInt (fromInteger y)
2759 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2761 returnNat (Any IntRep code__2)
2763 trivialCode instr x y
2764 = getRegister x `thenNat` \ register1 ->
2765 getRegister y `thenNat` \ register2 ->
2766 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2767 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2769 code1 = registerCode register1 tmp1 []
2770 src1 = registerName register1 tmp1
2771 code2 = registerCode register2 tmp2 []
2772 src2 = registerName register2 tmp2
2773 code__2 dst = asmSeqThen [code1, code2] .
2774 mkSeqInstr (instr src1 (RIReg src2) dst)
2776 returnNat (Any IntRep code__2)
2779 trivialUCode instr x
2780 = getRegister x `thenNat` \ register ->
2781 getNewRegNCG IntRep `thenNat` \ tmp ->
2783 code = registerCode register tmp
2784 src = registerName register tmp
2785 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2787 returnNat (Any IntRep code__2)
2790 trivialFCode _ instr x y
2791 = getRegister x `thenNat` \ register1 ->
2792 getRegister y `thenNat` \ register2 ->
2793 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2794 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2796 code1 = registerCode register1 tmp1
2797 src1 = registerName register1 tmp1
2799 code2 = registerCode register2 tmp2
2800 src2 = registerName register2 tmp2
2802 code__2 dst = asmSeqThen [code1 [], code2 []] .
2803 mkSeqInstr (instr src1 src2 dst)
2805 returnNat (Any DoubleRep code__2)
2807 trivialUFCode _ instr x
2808 = getRegister x `thenNat` \ register ->
2809 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2811 code = registerCode register tmp
2812 src = registerName register tmp
2813 code__2 dst = code . mkSeqInstr (instr src dst)
2815 returnNat (Any DoubleRep code__2)
2817 #endif {- alpha_TARGET_ARCH -}
2818 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2819 #if i386_TARGET_ARCH
2821 The Rules of the Game are:
2823 * You cannot assume anything about the destination register dst;
2824 it may be anything, including a fixed reg.
2826 * You may compute an operand into a fixed reg, but you may not
2827 subsequently change the contents of that fixed reg. If you
2828 want to do so, first copy the value either to a temporary
2829 or into dst. You are free to modify dst even if it happens
2830 to be a fixed reg -- that's not your problem.
2832 * You cannot assume that a fixed reg will stay live over an
2833 arbitrary computation. The same applies to the dst reg.
2835 * Temporary regs obtained from getNewRegNCG are distinct from
2836 each other and from all other regs, and stay live over
2837 arbitrary computations.
2841 trivialCode instr maybe_revinstr a b
2844 = getRegister a `thenNat` \ rega ->
2847 then registerCode rega dst `bind` \ code_a ->
2849 instr (OpImm imm_b) (OpReg dst)
2850 else registerCodeF rega `bind` \ code_a ->
2851 registerNameF rega `bind` \ r_a ->
2853 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2854 instr (OpImm imm_b) (OpReg dst)
2856 returnNat (Any IntRep mkcode)
2859 = getRegister b `thenNat` \ regb ->
2860 getNewRegNCG IntRep `thenNat` \ tmp ->
2861 let revinstr_avail = maybeToBool maybe_revinstr
2862 revinstr = case maybe_revinstr of Just ri -> ri
2866 then registerCode regb dst `bind` \ code_b ->
2868 revinstr (OpImm imm_a) (OpReg dst)
2869 else registerCodeF regb `bind` \ code_b ->
2870 registerNameF regb `bind` \ r_b ->
2872 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2873 revinstr (OpImm imm_a) (OpReg dst)
2877 then registerCode regb tmp `bind` \ code_b ->
2879 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2880 instr (OpReg tmp) (OpReg dst)
2881 else registerCodeF regb `bind` \ code_b ->
2882 registerNameF regb `bind` \ r_b ->
2884 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2885 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2886 instr (OpReg tmp) (OpReg dst)
2888 returnNat (Any IntRep mkcode)
2891 = getRegister a `thenNat` \ rega ->
2892 getRegister b `thenNat` \ regb ->
2893 getNewRegNCG IntRep `thenNat` \ tmp ->
2895 = case (isAny rega, isAny regb) of
2897 -> registerCode regb tmp `bind` \ code_b ->
2898 registerCode rega dst `bind` \ code_a ->
2901 instr (OpReg tmp) (OpReg dst)
2903 -> registerCode rega tmp `bind` \ code_a ->
2904 registerCodeF regb `bind` \ code_b ->
2905 registerNameF regb `bind` \ r_b ->
2908 instr (OpReg r_b) (OpReg tmp) `snocOL`
2909 MOV L (OpReg tmp) (OpReg dst)
2911 -> registerCode regb tmp `bind` \ code_b ->
2912 registerCodeF rega `bind` \ code_a ->
2913 registerNameF rega `bind` \ r_a ->
2916 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2917 instr (OpReg tmp) (OpReg dst)
2919 -> registerCodeF rega `bind` \ code_a ->
2920 registerNameF rega `bind` \ r_a ->
2921 registerCodeF regb `bind` \ code_b ->
2922 registerNameF regb `bind` \ r_b ->
2924 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2926 instr (OpReg r_b) (OpReg tmp) `snocOL`
2927 MOV L (OpReg tmp) (OpReg dst)
2929 returnNat (Any IntRep mkcode)
2932 maybe_imm_a = maybeImm a
2933 is_imm_a = maybeToBool maybe_imm_a
2934 imm_a = case maybe_imm_a of Just imm -> imm
2936 maybe_imm_b = maybeImm b
2937 is_imm_b = maybeToBool maybe_imm_b
2938 imm_b = case maybe_imm_b of Just imm -> imm
2942 trivialUCode instr x
2943 = getRegister x `thenNat` \ register ->
2945 code__2 dst = let code = registerCode register dst
2946 src = registerName register dst
2948 if isFixed register && dst /= src
2949 then toOL [MOV L (OpReg src) (OpReg dst),
2951 else unitOL (instr (OpReg src))
2953 returnNat (Any IntRep code__2)
2956 trivialFCode pk instr x y
2957 = getRegister x `thenNat` \ register1 ->
2958 getRegister y `thenNat` \ register2 ->
2959 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2960 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2962 code1 = registerCode register1 tmp1
2963 src1 = registerName register1 tmp1
2965 code2 = registerCode register2 tmp2
2966 src2 = registerName register2 tmp2
2969 -- treat the common case specially: both operands in
2971 | isAny register1 && isAny register2
2974 instr (primRepToSize pk) src1 src2 dst
2976 -- be paranoid (and inefficient)
2978 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2980 instr (primRepToSize pk) tmp1 src2 dst
2982 returnNat (Any pk code__2)
2986 trivialUFCode pk instr x
2987 = getRegister x `thenNat` \ register ->
2988 getNewRegNCG pk `thenNat` \ tmp ->
2990 code = registerCode register tmp
2991 src = registerName register tmp
2992 code__2 dst = code `snocOL` instr src dst
2994 returnNat (Any pk code__2)
2996 #endif {- i386_TARGET_ARCH -}
2997 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2998 #if sparc_TARGET_ARCH
3000 trivialCode instr x (StInt y)
3002 = getRegister x `thenNat` \ register ->
3003 getNewRegNCG IntRep `thenNat` \ tmp ->
3005 code = registerCode register tmp
3006 src1 = registerName register tmp
3007 src2 = ImmInt (fromInteger y)
3008 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3010 returnNat (Any IntRep code__2)
3012 trivialCode instr x y
3013 = getRegister x `thenNat` \ register1 ->
3014 getRegister y `thenNat` \ register2 ->
3015 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3016 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3018 code1 = registerCode register1 tmp1
3019 src1 = registerName register1 tmp1
3020 code2 = registerCode register2 tmp2
3021 src2 = registerName register2 tmp2
3022 code__2 dst = code1 `appOL` code2 `snocOL`
3023 instr src1 (RIReg src2) dst
3025 returnNat (Any IntRep code__2)
3028 trivialFCode pk instr x y
3029 = getRegister x `thenNat` \ register1 ->
3030 getRegister y `thenNat` \ register2 ->
3031 getNewRegNCG (registerRep register1)
3033 getNewRegNCG (registerRep register2)
3035 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3037 promote x = FxTOy F DF x tmp
3039 pk1 = registerRep register1
3040 code1 = registerCode register1 tmp1
3041 src1 = registerName register1 tmp1
3043 pk2 = registerRep register2
3044 code2 = registerCode register2 tmp2
3045 src2 = registerName register2 tmp2
3049 code1 `appOL` code2 `snocOL`
3050 instr (primRepToSize pk) src1 src2 dst
3051 else if pk1 == FloatRep then
3052 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3053 instr DF tmp src2 dst
3055 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3056 instr DF src1 tmp dst
3058 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3061 trivialUCode instr x
3062 = getRegister x `thenNat` \ register ->
3063 getNewRegNCG IntRep `thenNat` \ tmp ->
3065 code = registerCode register tmp
3066 src = registerName register tmp
3067 code__2 dst = code `snocOL` instr (RIReg src) dst
3069 returnNat (Any IntRep code__2)
3072 trivialUFCode pk instr x
3073 = getRegister x `thenNat` \ register ->
3074 getNewRegNCG pk `thenNat` \ tmp ->
3076 code = registerCode register tmp
3077 src = registerName register tmp
3078 code__2 dst = code `snocOL` instr src dst
3080 returnNat (Any pk code__2)
3082 #endif {- sparc_TARGET_ARCH -}
3085 %************************************************************************
3087 \subsubsection{Coercing to/from integer/floating-point...}
3089 %************************************************************************
3091 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3092 to be generated. Here we just change the type on the Register passed
3093 on up. The code is machine-independent.
3095 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3096 conversions. We have to store temporaries in memory to move
3097 between the integer and the floating point register sets.
3100 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3101 coerceFltCode :: StixTree -> NatM Register
3103 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3104 coerceFP2Int :: StixTree -> NatM Register
3107 = getRegister x `thenNat` \ register ->
3110 Fixed _ reg code -> Fixed pk reg code
3111 Any _ code -> Any pk code
3116 = getRegister x `thenNat` \ register ->
3119 Fixed _ reg code -> Fixed DoubleRep reg code
3120 Any _ code -> Any DoubleRep code
3125 #if alpha_TARGET_ARCH
3128 = getRegister x `thenNat` \ register ->
3129 getNewRegNCG IntRep `thenNat` \ reg ->
3131 code = registerCode register reg
3132 src = registerName register reg
3134 code__2 dst = code . mkSeqInstrs [
3136 LD TF dst (spRel 0),
3139 returnNat (Any DoubleRep code__2)
3143 = getRegister x `thenNat` \ register ->
3144 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3146 code = registerCode register tmp
3147 src = registerName register tmp
3149 code__2 dst = code . mkSeqInstrs [
3151 ST TF tmp (spRel 0),
3154 returnNat (Any IntRep code__2)
3156 #endif {- alpha_TARGET_ARCH -}
3157 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3158 #if i386_TARGET_ARCH
3161 = getRegister x `thenNat` \ register ->
3162 getNewRegNCG IntRep `thenNat` \ reg ->
3164 code = registerCode register reg
3165 src = registerName register reg
3166 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3167 code__2 dst = code `snocOL` opc src dst
3169 returnNat (Any pk code__2)
3173 = getRegister x `thenNat` \ register ->
3174 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3176 code = registerCode register tmp
3177 src = registerName register tmp
3178 pk = registerRep register
3180 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3181 code__2 dst = code `snocOL` opc src dst
3183 returnNat (Any IntRep code__2)
3185 #endif {- i386_TARGET_ARCH -}
3186 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3187 #if sparc_TARGET_ARCH
3190 = getRegister x `thenNat` \ register ->
3191 getNewRegNCG IntRep `thenNat` \ reg ->
3193 code = registerCode register reg
3194 src = registerName register reg
3196 code__2 dst = code `appOL` toOL [
3197 ST W src (spRel (-2)),
3198 LD W (spRel (-2)) dst,
3199 FxTOy W (primRepToSize pk) dst dst]
3201 returnNat (Any pk code__2)
3205 = getRegister x `thenNat` \ register ->
3206 getNewRegNCG IntRep `thenNat` \ reg ->
3207 getNewRegNCG FloatRep `thenNat` \ tmp ->
3209 code = registerCode register reg
3210 src = registerName register reg
3211 pk = registerRep register
3213 code__2 dst = code `appOL` toOL [
3214 FxTOy (primRepToSize pk) W src tmp,
3215 ST W tmp (spRel (-2)),
3216 LD W (spRel (-2)) dst]
3218 returnNat (Any IntRep code__2)
3220 #endif {- sparc_TARGET_ARCH -}
3223 %************************************************************************
3225 \subsubsection{Coercing integer to @Char@...}
3227 %************************************************************************
3229 Integer to character conversion.
3232 chrCode :: StixTree -> NatM Register
3234 #if alpha_TARGET_ARCH
3236 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3237 -- It should coerce a 64-bit value to a 32-bit value.
3240 = getRegister x `thenNat` \ register ->
3241 getNewRegNCG IntRep `thenNat` \ reg ->
3243 code = registerCode register reg
3244 src = registerName register reg
3245 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3247 returnNat (Any IntRep code__2)
3249 #endif {- alpha_TARGET_ARCH -}
3250 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3251 #if i386_TARGET_ARCH
3254 = getRegister x `thenNat` \ register ->
3257 Fixed _ reg code -> Fixed IntRep reg code
3258 Any _ code -> Any IntRep code
3261 #endif {- i386_TARGET_ARCH -}
3262 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3263 #if sparc_TARGET_ARCH
3266 = getRegister x `thenNat` \ register ->
3269 Fixed _ reg code -> Fixed IntRep reg code
3270 Any _ code -> Any IntRep code
3273 #endif {- sparc_TARGET_ARCH -}