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 BU -> MOVZxL BU (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 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
922 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
924 OrdOp -> coerceIntCode IntRep x
927 Float2IntOp -> coerceFP2Int x
928 Int2FloatOp -> coerceInt2FP FloatRep x
929 Double2IntOp -> coerceFP2Int x
930 Int2DoubleOp -> coerceInt2FP DoubleRep x
934 fixed_x = if is_float_op -- promote to double
935 then StPrim Float2DoubleOp [x]
938 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
942 FloatExpOp -> (True, SLIT("exp"))
943 FloatLogOp -> (True, SLIT("log"))
944 FloatSqrtOp -> (True, SLIT("sqrt"))
946 FloatSinOp -> (True, SLIT("sin"))
947 FloatCosOp -> (True, SLIT("cos"))
948 FloatTanOp -> (True, SLIT("tan"))
950 FloatAsinOp -> (True, SLIT("asin"))
951 FloatAcosOp -> (True, SLIT("acos"))
952 FloatAtanOp -> (True, SLIT("atan"))
954 FloatSinhOp -> (True, SLIT("sinh"))
955 FloatCoshOp -> (True, SLIT("cosh"))
956 FloatTanhOp -> (True, SLIT("tanh"))
958 DoubleExpOp -> (False, SLIT("exp"))
959 DoubleLogOp -> (False, SLIT("log"))
960 DoubleSqrtOp -> (False, SLIT("sqrt"))
962 DoubleSinOp -> (False, SLIT("sin"))
963 DoubleCosOp -> (False, SLIT("cos"))
964 DoubleTanOp -> (False, SLIT("tan"))
966 DoubleAsinOp -> (False, SLIT("asin"))
967 DoubleAcosOp -> (False, SLIT("acos"))
968 DoubleAtanOp -> (False, SLIT("atan"))
970 DoubleSinhOp -> (False, SLIT("sinh"))
971 DoubleCoshOp -> (False, SLIT("cosh"))
972 DoubleTanhOp -> (False, SLIT("tanh"))
975 -> pprPanic "getRegister(sparc,monadicprimop)"
976 (pprStixTree (StPrim primop [x]))
978 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
980 CharGtOp -> condIntReg GTT x y
981 CharGeOp -> condIntReg GE x y
982 CharEqOp -> condIntReg EQQ x y
983 CharNeOp -> condIntReg NE x y
984 CharLtOp -> condIntReg LTT x y
985 CharLeOp -> condIntReg LE x y
987 IntGtOp -> condIntReg GTT x y
988 IntGeOp -> condIntReg GE x y
989 IntEqOp -> condIntReg EQQ x y
990 IntNeOp -> condIntReg NE x y
991 IntLtOp -> condIntReg LTT x y
992 IntLeOp -> condIntReg LE x y
994 WordGtOp -> condIntReg GU x y
995 WordGeOp -> condIntReg GEU x y
996 WordEqOp -> condIntReg EQQ x y
997 WordNeOp -> condIntReg NE x y
998 WordLtOp -> condIntReg LU x y
999 WordLeOp -> condIntReg LEU x y
1001 AddrGtOp -> condIntReg GU x y
1002 AddrGeOp -> condIntReg GEU x y
1003 AddrEqOp -> condIntReg EQQ x y
1004 AddrNeOp -> condIntReg NE x y
1005 AddrLtOp -> condIntReg LU x y
1006 AddrLeOp -> condIntReg LEU x y
1008 FloatGtOp -> condFltReg GTT x y
1009 FloatGeOp -> condFltReg GE x y
1010 FloatEqOp -> condFltReg EQQ x y
1011 FloatNeOp -> condFltReg NE x y
1012 FloatLtOp -> condFltReg LTT x y
1013 FloatLeOp -> condFltReg LE x y
1015 DoubleGtOp -> condFltReg GTT x y
1016 DoubleGeOp -> condFltReg GE x y
1017 DoubleEqOp -> condFltReg EQQ x y
1018 DoubleNeOp -> condFltReg NE x y
1019 DoubleLtOp -> condFltReg LTT x y
1020 DoubleLeOp -> condFltReg LE x y
1022 IntAddOp -> trivialCode (ADD False False) x y
1023 IntSubOp -> trivialCode (SUB False False) x y
1025 -- ToDo: teach about V8+ SPARC mul/div instructions
1026 IntMulOp -> imul_div SLIT(".umul") x y
1027 IntQuotOp -> imul_div SLIT(".div") x y
1028 IntRemOp -> imul_div SLIT(".rem") x y
1030 FloatAddOp -> trivialFCode FloatRep FADD x y
1031 FloatSubOp -> trivialFCode FloatRep FSUB x y
1032 FloatMulOp -> trivialFCode FloatRep FMUL x y
1033 FloatDivOp -> trivialFCode FloatRep FDIV x y
1035 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1036 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1037 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1038 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1040 AndOp -> trivialCode (AND False) x y
1041 OrOp -> trivialCode (OR False) x y
1042 XorOp -> trivialCode (XOR False) x y
1043 SllOp -> trivialCode SLL x y
1044 SrlOp -> trivialCode SRL x y
1046 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1047 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1048 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1050 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1051 [promote x, promote y])
1052 where promote x = StPrim Float2DoubleOp [x]
1053 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1057 -> pprPanic "getRegister(sparc,dyadic primop)"
1058 (pprStixTree (StPrim primop [x, y]))
1061 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1063 getRegister (StInd pk mem)
1064 = getAmode mem `thenNat` \ amode ->
1066 code = amodeCode amode
1067 src = amodeAddr amode
1068 size = primRepToSize pk
1069 code__2 dst = code `snocOL` LD size src dst
1071 returnNat (Any pk code__2)
1073 getRegister (StInt i)
1076 src = ImmInt (fromInteger i)
1077 code dst = unitOL (OR False g0 (RIImm src) dst)
1079 returnNat (Any IntRep code)
1085 SETHI (HI imm__2) dst,
1086 OR False dst (RIImm (LO imm__2)) dst]
1088 returnNat (Any PtrRep code)
1090 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1093 imm__2 = case imm of Just x -> x
1095 #endif {- sparc_TARGET_ARCH -}
1098 %************************************************************************
1100 \subsection{The @Amode@ type}
1102 %************************************************************************
1104 @Amode@s: Memory addressing modes passed up the tree.
1106 data Amode = Amode MachRegsAddr InstrBlock
1108 amodeAddr (Amode addr _) = addr
1109 amodeCode (Amode _ code) = code
1112 Now, given a tree (the argument to an StInd) that references memory,
1113 produce a suitable addressing mode.
1115 A Rule of the Game (tm) for Amodes: use of the addr bit must
1116 immediately follow use of the code part, since the code part puts
1117 values in registers which the addr then refers to. So you can't put
1118 anything in between, lest it overwrite some of those registers. If
1119 you need to do some other computation between the code part and use of
1120 the addr bit, first store the effective address from the amode in a
1121 temporary, then do the other computation, and then use the temporary:
1125 ... other computation ...
1129 getAmode :: StixTree -> NatM Amode
1131 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1133 #if alpha_TARGET_ARCH
1135 getAmode (StPrim IntSubOp [x, StInt i])
1136 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1137 getRegister x `thenNat` \ register ->
1139 code = registerCode register tmp
1140 reg = registerName register tmp
1141 off = ImmInt (-(fromInteger i))
1143 returnNat (Amode (AddrRegImm reg off) code)
1145 getAmode (StPrim IntAddOp [x, StInt i])
1146 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1147 getRegister x `thenNat` \ register ->
1149 code = registerCode register tmp
1150 reg = registerName register tmp
1151 off = ImmInt (fromInteger i)
1153 returnNat (Amode (AddrRegImm reg off) code)
1157 = returnNat (Amode (AddrImm imm__2) id)
1160 imm__2 = case imm of Just x -> x
1163 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1164 getRegister other `thenNat` \ register ->
1166 code = registerCode register tmp
1167 reg = registerName register tmp
1169 returnNat (Amode (AddrReg reg) code)
1171 #endif {- alpha_TARGET_ARCH -}
1172 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1173 #if i386_TARGET_ARCH
1175 getAmode (StPrim IntSubOp [x, StInt i])
1176 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1177 getRegister x `thenNat` \ register ->
1179 code = registerCode register tmp
1180 reg = registerName register tmp
1181 off = ImmInt (-(fromInteger i))
1183 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1185 getAmode (StPrim IntAddOp [x, StInt i])
1187 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1190 imm__2 = case imm of Just x -> x
1192 getAmode (StPrim IntAddOp [x, StInt i])
1193 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1194 getRegister x `thenNat` \ register ->
1196 code = registerCode register tmp
1197 reg = registerName register tmp
1198 off = ImmInt (fromInteger i)
1200 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1202 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1203 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1204 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1205 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1206 getRegister x `thenNat` \ register1 ->
1207 getRegister y `thenNat` \ register2 ->
1209 code1 = registerCode register1 tmp1
1210 reg1 = registerName register1 tmp1
1211 code2 = registerCode register2 tmp2
1212 reg2 = registerName register2 tmp2
1213 code__2 = code1 `appOL` code2
1214 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1216 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1221 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1224 imm__2 = case imm of Just x -> x
1227 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1228 getRegister other `thenNat` \ register ->
1230 code = registerCode register tmp
1231 reg = registerName register tmp
1233 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1235 #endif {- i386_TARGET_ARCH -}
1236 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1237 #if sparc_TARGET_ARCH
1239 getAmode (StPrim IntSubOp [x, StInt i])
1241 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1242 getRegister x `thenNat` \ register ->
1244 code = registerCode register tmp
1245 reg = registerName register tmp
1246 off = ImmInt (-(fromInteger i))
1248 returnNat (Amode (AddrRegImm reg off) code)
1251 getAmode (StPrim IntAddOp [x, StInt i])
1253 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1254 getRegister x `thenNat` \ register ->
1256 code = registerCode register tmp
1257 reg = registerName register tmp
1258 off = ImmInt (fromInteger i)
1260 returnNat (Amode (AddrRegImm reg off) code)
1262 getAmode (StPrim IntAddOp [x, y])
1263 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1264 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1265 getRegister x `thenNat` \ register1 ->
1266 getRegister y `thenNat` \ register2 ->
1268 code1 = registerCode register1 tmp1
1269 reg1 = registerName register1 tmp1
1270 code2 = registerCode register2 tmp2
1271 reg2 = registerName register2 tmp2
1272 code__2 = code1 `appOL` code2
1274 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1278 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1280 code = unitOL (SETHI (HI imm__2) tmp)
1282 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1285 imm__2 = case imm of Just x -> x
1288 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1289 getRegister other `thenNat` \ register ->
1291 code = registerCode register tmp
1292 reg = registerName register tmp
1295 returnNat (Amode (AddrRegImm reg off) code)
1297 #endif {- sparc_TARGET_ARCH -}
1300 %************************************************************************
1302 \subsection{The @CondCode@ type}
1304 %************************************************************************
1306 Condition codes passed up the tree.
1308 data CondCode = CondCode Bool Cond InstrBlock
1310 condName (CondCode _ cond _) = cond
1311 condFloat (CondCode is_float _ _) = is_float
1312 condCode (CondCode _ _ code) = code
1315 Set up a condition code for a conditional branch.
1318 getCondCode :: StixTree -> NatM CondCode
1320 #if alpha_TARGET_ARCH
1321 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1322 #endif {- alpha_TARGET_ARCH -}
1323 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1325 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1326 -- yes, they really do seem to want exactly the same!
1328 getCondCode (StPrim primop [x, y])
1330 CharGtOp -> condIntCode GTT x y
1331 CharGeOp -> condIntCode GE x y
1332 CharEqOp -> condIntCode EQQ x y
1333 CharNeOp -> condIntCode NE x y
1334 CharLtOp -> condIntCode LTT x y
1335 CharLeOp -> condIntCode LE x y
1337 IntGtOp -> condIntCode GTT x y
1338 IntGeOp -> condIntCode GE x y
1339 IntEqOp -> condIntCode EQQ x y
1340 IntNeOp -> condIntCode NE x y
1341 IntLtOp -> condIntCode LTT x y
1342 IntLeOp -> condIntCode LE x y
1344 WordGtOp -> condIntCode GU x y
1345 WordGeOp -> condIntCode GEU x y
1346 WordEqOp -> condIntCode EQQ x y
1347 WordNeOp -> condIntCode NE x y
1348 WordLtOp -> condIntCode LU x y
1349 WordLeOp -> condIntCode LEU x y
1351 AddrGtOp -> condIntCode GU x y
1352 AddrGeOp -> condIntCode GEU x y
1353 AddrEqOp -> condIntCode EQQ x y
1354 AddrNeOp -> condIntCode NE x y
1355 AddrLtOp -> condIntCode LU x y
1356 AddrLeOp -> condIntCode LEU x y
1358 FloatGtOp -> condFltCode GTT x y
1359 FloatGeOp -> condFltCode GE x y
1360 FloatEqOp -> condFltCode EQQ x y
1361 FloatNeOp -> condFltCode NE x y
1362 FloatLtOp -> condFltCode LTT x y
1363 FloatLeOp -> condFltCode LE x y
1365 DoubleGtOp -> condFltCode GTT x y
1366 DoubleGeOp -> condFltCode GE x y
1367 DoubleEqOp -> condFltCode EQQ x y
1368 DoubleNeOp -> condFltCode NE x y
1369 DoubleLtOp -> condFltCode LTT x y
1370 DoubleLeOp -> condFltCode LE x y
1372 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1377 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1378 passed back up the tree.
1381 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1383 #if alpha_TARGET_ARCH
1384 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1385 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1386 #endif {- alpha_TARGET_ARCH -}
1388 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1389 #if i386_TARGET_ARCH
1391 -- memory vs immediate
1392 condIntCode cond (StInd pk x) y
1394 = getAmode x `thenNat` \ amode ->
1396 code1 = amodeCode amode
1397 x__2 = amodeAddr amode
1398 sz = primRepToSize pk
1399 code__2 = code1 `snocOL`
1400 CMP sz (OpImm imm__2) (OpAddr x__2)
1402 returnNat (CondCode False cond code__2)
1405 imm__2 = case imm of Just x -> x
1408 condIntCode cond x (StInt 0)
1409 = getRegister x `thenNat` \ register1 ->
1410 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1412 code1 = registerCode register1 tmp1
1413 src1 = registerName register1 tmp1
1414 code__2 = code1 `snocOL`
1415 TEST L (OpReg src1) (OpReg src1)
1417 returnNat (CondCode False cond code__2)
1419 -- anything vs immediate
1420 condIntCode cond x y
1422 = getRegister x `thenNat` \ register1 ->
1423 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1425 code1 = registerCode register1 tmp1
1426 src1 = registerName register1 tmp1
1427 code__2 = code1 `snocOL`
1428 CMP L (OpImm imm__2) (OpReg src1)
1430 returnNat (CondCode False cond code__2)
1433 imm__2 = case imm of Just x -> x
1435 -- memory vs anything
1436 condIntCode cond (StInd pk x) y
1437 = getAmode x `thenNat` \ amode_x ->
1438 getRegister y `thenNat` \ reg_y ->
1439 getNewRegNCG IntRep `thenNat` \ tmp ->
1441 c_x = amodeCode amode_x
1442 am_x = amodeAddr amode_x
1443 c_y = registerCode reg_y tmp
1444 r_y = registerName reg_y tmp
1445 sz = primRepToSize pk
1447 -- optimisation: if there's no code for x, just an amode,
1448 -- use whatever reg y winds up in. Assumes that c_y doesn't
1449 -- clobber any regs in the amode am_x, which I'm not sure is
1450 -- justified. The otherwise clause makes the same assumption.
1451 code__2 | isNilOL c_x
1453 CMP sz (OpReg r_y) (OpAddr am_x)
1457 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1459 CMP sz (OpReg tmp) (OpAddr am_x)
1461 returnNat (CondCode False cond code__2)
1463 -- anything vs memory
1465 condIntCode cond y (StInd pk x)
1466 = getAmode x `thenNat` \ amode_x ->
1467 getRegister y `thenNat` \ reg_y ->
1468 getNewRegNCG IntRep `thenNat` \ tmp ->
1470 c_x = amodeCode amode_x
1471 am_x = amodeAddr amode_x
1472 c_y = registerCode reg_y tmp
1473 r_y = registerName reg_y tmp
1474 sz = primRepToSize pk
1475 -- same optimisation and nagging doubts as previous clause
1476 code__2 | isNilOL c_x
1478 CMP sz (OpAddr am_x) (OpReg r_y)
1482 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1484 CMP sz (OpAddr am_x) (OpReg tmp)
1486 returnNat (CondCode False cond code__2)
1488 -- anything vs anything
1489 condIntCode cond x y
1490 = getRegister x `thenNat` \ register1 ->
1491 getRegister y `thenNat` \ register2 ->
1492 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1493 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1495 code1 = registerCode register1 tmp1
1496 src1 = registerName register1 tmp1
1497 code2 = registerCode register2 tmp2
1498 src2 = registerName register2 tmp2
1499 code__2 = code1 `snocOL`
1500 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1502 CMP L (OpReg src2) (OpReg tmp1)
1504 returnNat (CondCode False cond code__2)
1507 condFltCode cond x y
1508 = getRegister x `thenNat` \ register1 ->
1509 getRegister y `thenNat` \ register2 ->
1510 getNewRegNCG (registerRep register1)
1512 getNewRegNCG (registerRep register2)
1514 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1516 pk1 = registerRep register1
1517 code1 = registerCode register1 tmp1
1518 src1 = registerName register1 tmp1
1520 code2 = registerCode register2 tmp2
1521 src2 = registerName register2 tmp2
1523 code__2 | isAny register1
1524 = code1 `appOL` -- result in tmp1
1526 GCMP (primRepToSize pk1) tmp1 src2
1530 GMOV src1 tmp1 `appOL`
1532 GCMP (primRepToSize pk1) tmp1 src2
1534 {- On the 486, the flags set by FP compare are the unsigned ones!
1535 (This looks like a HACK to me. WDP 96/03)
1537 fix_FP_cond :: Cond -> Cond
1539 fix_FP_cond GE = GEU
1540 fix_FP_cond GTT = GU
1541 fix_FP_cond LTT = LU
1542 fix_FP_cond LE = LEU
1543 fix_FP_cond any = any
1545 returnNat (CondCode True (fix_FP_cond cond) code__2)
1549 #endif {- i386_TARGET_ARCH -}
1550 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1551 #if sparc_TARGET_ARCH
1553 condIntCode cond x (StInt y)
1555 = getRegister x `thenNat` \ register ->
1556 getNewRegNCG IntRep `thenNat` \ tmp ->
1558 code = registerCode register tmp
1559 src1 = registerName register tmp
1560 src2 = ImmInt (fromInteger y)
1561 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1563 returnNat (CondCode False cond code__2)
1565 condIntCode cond x y
1566 = getRegister x `thenNat` \ register1 ->
1567 getRegister y `thenNat` \ register2 ->
1568 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1569 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1571 code1 = registerCode register1 tmp1
1572 src1 = registerName register1 tmp1
1573 code2 = registerCode register2 tmp2
1574 src2 = registerName register2 tmp2
1575 code__2 = code1 `appOL` code2 `snocOL`
1576 SUB False True src1 (RIReg src2) g0
1578 returnNat (CondCode False cond code__2)
1581 condFltCode cond x y
1582 = getRegister x `thenNat` \ register1 ->
1583 getRegister y `thenNat` \ register2 ->
1584 getNewRegNCG (registerRep register1)
1586 getNewRegNCG (registerRep register2)
1588 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1590 promote x = FxTOy F DF x tmp
1592 pk1 = registerRep register1
1593 code1 = registerCode register1 tmp1
1594 src1 = registerName register1 tmp1
1596 pk2 = registerRep register2
1597 code2 = registerCode register2 tmp2
1598 src2 = registerName register2 tmp2
1602 code1 `appOL` code2 `snocOL`
1603 FCMP True (primRepToSize pk1) src1 src2
1604 else if pk1 == FloatRep then
1605 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1606 FCMP True DF tmp src2
1608 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1609 FCMP True DF src1 tmp
1611 returnNat (CondCode True cond code__2)
1613 #endif {- sparc_TARGET_ARCH -}
1616 %************************************************************************
1618 \subsection{Generating assignments}
1620 %************************************************************************
1622 Assignments are really at the heart of the whole code generation
1623 business. Almost all top-level nodes of any real importance are
1624 assignments, which correspond to loads, stores, or register transfers.
1625 If we're really lucky, some of the register transfers will go away,
1626 because we can use the destination register to complete the code
1627 generation for the right hand side. This only fails when the right
1628 hand side is forced into a fixed register (e.g. the result of a call).
1631 assignIntCode, assignFltCode
1632 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1634 #if alpha_TARGET_ARCH
1636 assignIntCode pk (StInd _ dst) src
1637 = getNewRegNCG IntRep `thenNat` \ tmp ->
1638 getAmode dst `thenNat` \ amode ->
1639 getRegister src `thenNat` \ register ->
1641 code1 = amodeCode amode []
1642 dst__2 = amodeAddr amode
1643 code2 = registerCode register tmp []
1644 src__2 = registerName register tmp
1645 sz = primRepToSize pk
1646 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1650 assignIntCode pk dst src
1651 = getRegister dst `thenNat` \ register1 ->
1652 getRegister src `thenNat` \ register2 ->
1654 dst__2 = registerName register1 zeroh
1655 code = registerCode register2 dst__2
1656 src__2 = registerName register2 dst__2
1657 code__2 = if isFixed register2
1658 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1663 #endif {- alpha_TARGET_ARCH -}
1664 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1665 #if i386_TARGET_ARCH
1667 -- Destination of an assignment can only be reg or mem.
1668 -- This is the mem case.
1669 assignIntCode pk (StInd _ dst) src
1670 = getAmode dst `thenNat` \ amode ->
1671 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1672 getNewRegNCG PtrRep `thenNat` \ tmp ->
1674 -- In general, if the address computation for dst may require
1675 -- some insns preceding the addressing mode itself. So there's
1676 -- no guarantee that the code for dst and the code for src won't
1677 -- write the same register. This means either the address or
1678 -- the value needs to be copied into a temporary. We detect the
1679 -- common case where the amode has no code, and elide the copy.
1680 codea = amodeCode amode
1681 dst__a = amodeAddr amode
1683 code | isNilOL codea
1685 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1689 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1691 MOV (primRepToSize pk) opsrc
1692 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1698 -> NatM (InstrBlock,Operand) -- code, operator
1702 = returnNat (nilOL, OpImm imm_op)
1705 imm_op = case imm of Just x -> x
1708 = getRegister op `thenNat` \ register ->
1709 getNewRegNCG (registerRep register)
1711 let code = registerCode register tmp
1712 reg = registerName register tmp
1714 returnNat (code, OpReg reg)
1716 -- Assign; dst is a reg, rhs is mem
1717 assignIntCode pk dst (StInd pks src)
1718 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1719 getAmode src `thenNat` \ amode ->
1720 getRegister dst `thenNat` \ reg_dst ->
1722 c_addr = amodeCode amode
1723 am_addr = amodeAddr amode
1725 c_dst = registerCode reg_dst tmp -- should be empty
1726 r_dst = registerName reg_dst tmp
1727 szs = primRepToSize pks
1728 opc = case szs of L -> MOV L ; BU -> MOVZxL BU
1730 code | isNilOL c_dst
1732 opc (OpAddr am_addr) (OpReg r_dst)
1734 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1738 -- dst is a reg, but src could be anything
1739 assignIntCode pk dst src
1740 = getRegister dst `thenNat` \ registerd ->
1741 getRegister src `thenNat` \ registers ->
1742 getNewRegNCG IntRep `thenNat` \ tmp ->
1744 r_dst = registerName registerd tmp
1745 c_dst = registerCode registerd tmp -- should be empty
1746 r_src = registerName registers r_dst
1747 c_src = registerCode registers r_dst
1749 code | isNilOL c_dst
1751 MOV L (OpReg r_src) (OpReg r_dst)
1753 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1757 #endif {- i386_TARGET_ARCH -}
1758 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1759 #if sparc_TARGET_ARCH
1761 assignIntCode pk (StInd _ dst) src
1762 = getNewRegNCG IntRep `thenNat` \ tmp ->
1763 getAmode dst `thenNat` \ amode ->
1764 getRegister src `thenNat` \ register ->
1766 code1 = amodeCode amode
1767 dst__2 = amodeAddr amode
1768 code2 = registerCode register tmp
1769 src__2 = registerName register tmp
1770 sz = primRepToSize pk
1771 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1775 assignIntCode pk dst src
1776 = getRegister dst `thenNat` \ register1 ->
1777 getRegister src `thenNat` \ register2 ->
1779 dst__2 = registerName register1 g0
1780 code = registerCode register2 dst__2
1781 src__2 = registerName register2 dst__2
1782 code__2 = if isFixed register2
1783 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1788 #endif {- sparc_TARGET_ARCH -}
1791 % --------------------------------
1792 Floating-point assignments:
1793 % --------------------------------
1795 #if alpha_TARGET_ARCH
1797 assignFltCode pk (StInd _ dst) src
1798 = getNewRegNCG pk `thenNat` \ tmp ->
1799 getAmode dst `thenNat` \ amode ->
1800 getRegister src `thenNat` \ register ->
1802 code1 = amodeCode amode []
1803 dst__2 = amodeAddr amode
1804 code2 = registerCode register tmp []
1805 src__2 = registerName register tmp
1806 sz = primRepToSize pk
1807 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1811 assignFltCode pk dst src
1812 = getRegister dst `thenNat` \ register1 ->
1813 getRegister src `thenNat` \ register2 ->
1815 dst__2 = registerName register1 zeroh
1816 code = registerCode register2 dst__2
1817 src__2 = registerName register2 dst__2
1818 code__2 = if isFixed register2
1819 then code . mkSeqInstr (FMOV src__2 dst__2)
1824 #endif {- alpha_TARGET_ARCH -}
1825 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1826 #if i386_TARGET_ARCH
1829 assignFltCode pk (StInd pk_dst addr) src
1831 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1833 = getRegister src `thenNat` \ reg_src ->
1834 getRegister addr `thenNat` \ reg_addr ->
1835 getNewRegNCG pk `thenNat` \ tmp_src ->
1836 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1837 let r_src = registerName reg_src tmp_src
1838 c_src = registerCode reg_src tmp_src
1839 r_addr = registerName reg_addr tmp_addr
1840 c_addr = registerCode reg_addr tmp_addr
1841 sz = primRepToSize pk
1843 code = c_src `appOL`
1844 -- no need to preserve r_src across the addr computation,
1845 -- since r_src must be a float reg
1846 -- whilst r_addr is an int reg
1849 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1853 -- dst must be a (FP) register
1854 assignFltCode pk dst src
1855 = getRegister dst `thenNat` \ reg_dst ->
1856 getRegister src `thenNat` \ reg_src ->
1857 getNewRegNCG pk `thenNat` \ tmp ->
1859 r_dst = registerName reg_dst tmp
1860 c_dst = registerCode reg_dst tmp -- should be empty
1862 r_src = registerName reg_src r_dst
1863 c_src = registerCode reg_src r_dst
1865 code | isNilOL c_dst
1866 = if isFixed reg_src
1867 then c_src `snocOL` GMOV r_src r_dst
1870 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1876 #endif {- i386_TARGET_ARCH -}
1877 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1878 #if sparc_TARGET_ARCH
1880 assignFltCode pk (StInd _ dst) src
1881 = getNewRegNCG pk `thenNat` \ tmp1 ->
1882 getAmode dst `thenNat` \ amode ->
1883 getRegister src `thenNat` \ register ->
1885 sz = primRepToSize pk
1886 dst__2 = amodeAddr amode
1888 code1 = amodeCode amode
1889 code2 = registerCode register tmp1
1891 src__2 = registerName register tmp1
1892 pk__2 = registerRep register
1893 sz__2 = primRepToSize pk__2
1895 code__2 = code1 `appOL` code2 `appOL`
1897 then unitOL (ST sz src__2 dst__2)
1898 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1902 assignFltCode pk dst src
1903 = getRegister dst `thenNat` \ register1 ->
1904 getRegister src `thenNat` \ register2 ->
1906 pk__2 = registerRep register2
1907 sz__2 = primRepToSize pk__2
1909 getNewRegNCG pk__2 `thenNat` \ tmp ->
1911 sz = primRepToSize pk
1912 dst__2 = registerName register1 g0 -- must be Fixed
1915 reg__2 = if pk /= pk__2 then tmp else dst__2
1917 code = registerCode register2 reg__2
1919 src__2 = registerName register2 reg__2
1923 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1924 else if isFixed register2 then
1925 code `snocOL` FMOV sz src__2 dst__2
1931 #endif {- sparc_TARGET_ARCH -}
1934 %************************************************************************
1936 \subsection{Generating an unconditional branch}
1938 %************************************************************************
1940 We accept two types of targets: an immediate CLabel or a tree that
1941 gets evaluated into a register. Any CLabels which are AsmTemporaries
1942 are assumed to be in the local block of code, close enough for a
1943 branch instruction. Other CLabels are assumed to be far away.
1945 (If applicable) Do not fill the delay slots here; you will confuse the
1949 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
1951 #if alpha_TARGET_ARCH
1953 genJump (StCLbl lbl)
1954 | isAsmTemp lbl = returnInstr (BR target)
1955 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1957 target = ImmCLbl lbl
1960 = getRegister tree `thenNat` \ register ->
1961 getNewRegNCG PtrRep `thenNat` \ tmp ->
1963 dst = registerName register pv
1964 code = registerCode register pv
1965 target = registerName register pv
1967 if isFixed register then
1968 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1970 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1972 #endif {- alpha_TARGET_ARCH -}
1973 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1974 #if i386_TARGET_ARCH
1976 genJump dsts (StInd pk mem)
1977 = getAmode mem `thenNat` \ amode ->
1979 code = amodeCode amode
1980 target = amodeAddr amode
1982 returnNat (code `snocOL` JMP dsts (OpAddr target))
1986 = returnNat (unitOL (JMP dsts (OpImm target)))
1989 = getRegister tree `thenNat` \ register ->
1990 getNewRegNCG PtrRep `thenNat` \ tmp ->
1992 code = registerCode register tmp
1993 target = registerName register tmp
1995 returnNat (code `snocOL` JMP dsts (OpReg target))
1998 target = case imm of Just x -> x
2000 #endif {- i386_TARGET_ARCH -}
2001 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2002 #if sparc_TARGET_ARCH
2004 genJump dsts (StCLbl lbl)
2005 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2006 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2007 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2009 target = ImmCLbl lbl
2012 = getRegister tree `thenNat` \ register ->
2013 getNewRegNCG PtrRep `thenNat` \ tmp ->
2015 code = registerCode register tmp
2016 target = registerName register tmp
2018 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2020 #endif {- sparc_TARGET_ARCH -}
2023 %************************************************************************
2025 \subsection{Conditional jumps}
2027 %************************************************************************
2029 Conditional jumps are always to local labels, so we can use branch
2030 instructions. We peek at the arguments to decide what kind of
2033 ALPHA: For comparisons with 0, we're laughing, because we can just do
2034 the desired conditional branch.
2036 I386: First, we have to ensure that the condition
2037 codes are set according to the supplied comparison operation.
2039 SPARC: First, we have to ensure that the condition codes are set
2040 according to the supplied comparison operation. We generate slightly
2041 different code for floating point comparisons, because a floating
2042 point operation cannot directly precede a @BF@. We assume the worst
2043 and fill that slot with a @NOP@.
2045 SPARC: Do not fill the delay slots here; you will confuse the register
2050 :: CLabel -- the branch target
2051 -> StixTree -- the condition on which to branch
2054 #if alpha_TARGET_ARCH
2056 genCondJump lbl (StPrim op [x, StInt 0])
2057 = getRegister x `thenNat` \ register ->
2058 getNewRegNCG (registerRep register)
2061 code = registerCode register tmp
2062 value = registerName register tmp
2063 pk = registerRep register
2064 target = ImmCLbl lbl
2066 returnSeq code [BI (cmpOp op) value target]
2068 cmpOp CharGtOp = GTT
2070 cmpOp CharEqOp = EQQ
2072 cmpOp CharLtOp = LTT
2081 cmpOp WordGeOp = ALWAYS
2082 cmpOp WordEqOp = EQQ
2084 cmpOp WordLtOp = NEVER
2085 cmpOp WordLeOp = EQQ
2087 cmpOp AddrGeOp = ALWAYS
2088 cmpOp AddrEqOp = EQQ
2090 cmpOp AddrLtOp = NEVER
2091 cmpOp AddrLeOp = EQQ
2093 genCondJump lbl (StPrim op [x, StDouble 0.0])
2094 = getRegister x `thenNat` \ register ->
2095 getNewRegNCG (registerRep register)
2098 code = registerCode register tmp
2099 value = registerName register tmp
2100 pk = registerRep register
2101 target = ImmCLbl lbl
2103 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2105 cmpOp FloatGtOp = GTT
2106 cmpOp FloatGeOp = GE
2107 cmpOp FloatEqOp = EQQ
2108 cmpOp FloatNeOp = NE
2109 cmpOp FloatLtOp = LTT
2110 cmpOp FloatLeOp = LE
2111 cmpOp DoubleGtOp = GTT
2112 cmpOp DoubleGeOp = GE
2113 cmpOp DoubleEqOp = EQQ
2114 cmpOp DoubleNeOp = NE
2115 cmpOp DoubleLtOp = LTT
2116 cmpOp DoubleLeOp = LE
2118 genCondJump lbl (StPrim op [x, y])
2120 = trivialFCode pr instr x y `thenNat` \ register ->
2121 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2123 code = registerCode register tmp
2124 result = registerName register tmp
2125 target = ImmCLbl lbl
2127 returnNat (code . mkSeqInstr (BF cond result target))
2129 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2131 fltCmpOp op = case op of
2145 (instr, cond) = case op of
2146 FloatGtOp -> (FCMP TF LE, EQQ)
2147 FloatGeOp -> (FCMP TF LTT, EQQ)
2148 FloatEqOp -> (FCMP TF EQQ, NE)
2149 FloatNeOp -> (FCMP TF EQQ, EQQ)
2150 FloatLtOp -> (FCMP TF LTT, NE)
2151 FloatLeOp -> (FCMP TF LE, NE)
2152 DoubleGtOp -> (FCMP TF LE, EQQ)
2153 DoubleGeOp -> (FCMP TF LTT, EQQ)
2154 DoubleEqOp -> (FCMP TF EQQ, NE)
2155 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2156 DoubleLtOp -> (FCMP TF LTT, NE)
2157 DoubleLeOp -> (FCMP TF LE, NE)
2159 genCondJump lbl (StPrim op [x, y])
2160 = trivialCode instr x y `thenNat` \ register ->
2161 getNewRegNCG IntRep `thenNat` \ tmp ->
2163 code = registerCode register tmp
2164 result = registerName register tmp
2165 target = ImmCLbl lbl
2167 returnNat (code . mkSeqInstr (BI cond result target))
2169 (instr, cond) = case op of
2170 CharGtOp -> (CMP LE, EQQ)
2171 CharGeOp -> (CMP LTT, EQQ)
2172 CharEqOp -> (CMP EQQ, NE)
2173 CharNeOp -> (CMP EQQ, EQQ)
2174 CharLtOp -> (CMP LTT, NE)
2175 CharLeOp -> (CMP LE, NE)
2176 IntGtOp -> (CMP LE, EQQ)
2177 IntGeOp -> (CMP LTT, EQQ)
2178 IntEqOp -> (CMP EQQ, NE)
2179 IntNeOp -> (CMP EQQ, EQQ)
2180 IntLtOp -> (CMP LTT, NE)
2181 IntLeOp -> (CMP LE, NE)
2182 WordGtOp -> (CMP ULE, EQQ)
2183 WordGeOp -> (CMP ULT, EQQ)
2184 WordEqOp -> (CMP EQQ, NE)
2185 WordNeOp -> (CMP EQQ, EQQ)
2186 WordLtOp -> (CMP ULT, NE)
2187 WordLeOp -> (CMP ULE, NE)
2188 AddrGtOp -> (CMP ULE, EQQ)
2189 AddrGeOp -> (CMP ULT, EQQ)
2190 AddrEqOp -> (CMP EQQ, NE)
2191 AddrNeOp -> (CMP EQQ, EQQ)
2192 AddrLtOp -> (CMP ULT, NE)
2193 AddrLeOp -> (CMP ULE, NE)
2195 #endif {- alpha_TARGET_ARCH -}
2196 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2197 #if i386_TARGET_ARCH
2199 genCondJump lbl bool
2200 = getCondCode bool `thenNat` \ condition ->
2202 code = condCode condition
2203 cond = condName condition
2205 returnNat (code `snocOL` JXX cond lbl)
2207 #endif {- i386_TARGET_ARCH -}
2208 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2209 #if sparc_TARGET_ARCH
2211 genCondJump lbl bool
2212 = getCondCode bool `thenNat` \ condition ->
2214 code = condCode condition
2215 cond = condName condition
2216 target = ImmCLbl lbl
2221 if condFloat condition
2222 then [NOP, BF cond False target, NOP]
2223 else [BI cond False target, NOP]
2227 #endif {- sparc_TARGET_ARCH -}
2230 %************************************************************************
2232 \subsection{Generating C calls}
2234 %************************************************************************
2236 Now the biggest nightmare---calls. Most of the nastiness is buried in
2237 @get_arg@, which moves the arguments to the correct registers/stack
2238 locations. Apart from that, the code is easy.
2240 (If applicable) Do not fill the delay slots here; you will confuse the
2245 :: FAST_STRING -- function to call
2247 -> PrimRep -- type of the result
2248 -> [StixTree] -- arguments (of mixed type)
2251 #if alpha_TARGET_ARCH
2253 genCCall fn cconv kind args
2254 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2255 `thenNat` \ ((unused,_), argCode) ->
2257 nRegs = length allArgRegs - length unused
2258 code = asmSeqThen (map ($ []) argCode)
2261 LDA pv (AddrImm (ImmLab (ptext fn))),
2262 JSR ra (AddrReg pv) nRegs,
2263 LDGP gp (AddrReg ra)]
2265 ------------------------
2266 {- Try to get a value into a specific register (or registers) for
2267 a call. The first 6 arguments go into the appropriate
2268 argument register (separate registers for integer and floating
2269 point arguments, but used in lock-step), and the remaining
2270 arguments are dumped to the stack, beginning at 0(sp). Our
2271 first argument is a pair of the list of remaining argument
2272 registers to be assigned for this call and the next stack
2273 offset to use for overflowing arguments. This way,
2274 @get_Arg@ can be applied to all of a call's arguments using
2278 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2279 -> StixTree -- Current argument
2280 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2282 -- We have to use up all of our argument registers first...
2284 get_arg ((iDst,fDst):dsts, offset) arg
2285 = getRegister arg `thenNat` \ register ->
2287 reg = if isFloatingRep pk then fDst else iDst
2288 code = registerCode register reg
2289 src = registerName register reg
2290 pk = registerRep register
2293 if isFloatingRep pk then
2294 ((dsts, offset), if isFixed register then
2295 code . mkSeqInstr (FMOV src fDst)
2298 ((dsts, offset), if isFixed register then
2299 code . mkSeqInstr (OR src (RIReg src) iDst)
2302 -- Once we have run out of argument registers, we move to the
2305 get_arg ([], offset) arg
2306 = getRegister arg `thenNat` \ register ->
2307 getNewRegNCG (registerRep register)
2310 code = registerCode register tmp
2311 src = registerName register tmp
2312 pk = registerRep register
2313 sz = primRepToSize pk
2315 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2317 #endif {- alpha_TARGET_ARCH -}
2318 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2319 #if i386_TARGET_ARCH
2321 genCCall fn cconv kind [StInt i]
2322 | fn == SLIT ("PerformGC_wrapper")
2324 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2325 CALL (ImmLit (ptext (if underscorePrefix
2326 then (SLIT ("_PerformGC_wrapper"))
2327 else (SLIT ("PerformGC_wrapper")))))
2333 genCCall fn cconv kind args
2334 = mapNat get_call_arg
2335 (reverse args) `thenNat` \ sizes_n_codes ->
2336 getDeltaNat `thenNat` \ delta ->
2337 let (sizes, codes) = unzip sizes_n_codes
2338 tot_arg_size = sum sizes
2339 code2 = concatOL codes
2341 [CALL (fn__2 tot_arg_size)]
2343 (if cconv == stdCallConv then [] else
2344 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2346 [DELTA (delta + tot_arg_size)]
2349 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2350 returnNat (code2 `appOL` call)
2353 -- function names that begin with '.' are assumed to be special
2354 -- internally generated names like '.mul,' which don't get an
2355 -- underscore prefix
2356 -- ToDo:needed (WDP 96/03) ???
2360 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2362 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2364 stdcallsize tot_arg_size
2365 | cconv == stdCallConv = '@':show tot_arg_size
2373 get_call_arg :: StixTree{-current argument-}
2374 -> NatM (Int, InstrBlock) -- argsz, code
2377 = get_op arg `thenNat` \ (code, reg, sz) ->
2378 getDeltaNat `thenNat` \ delta ->
2379 arg_size sz `bind` \ size ->
2380 setDeltaNat (delta-size) `thenNat` \ _ ->
2381 if (case sz of DF -> True; F -> True; _ -> False)
2382 then returnNat (size,
2384 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2386 GST sz reg (AddrBaseIndex (Just esp)
2390 else returnNat (size,
2392 PUSH L (OpReg reg) `snocOL`
2398 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2401 = getRegister op `thenNat` \ register ->
2402 getNewRegNCG (registerRep register)
2405 code = registerCode register tmp
2406 reg = registerName register tmp
2407 pk = registerRep register
2408 sz = primRepToSize pk
2410 returnNat (code, reg, sz)
2412 #endif {- i386_TARGET_ARCH -}
2413 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2414 #if sparc_TARGET_ARCH
2416 The SPARC calling convention is an absolute
2417 nightmare. The first 6x32 bits of arguments are mapped into
2418 %o0 through %o5, and the remaining arguments are dumped to the
2419 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2421 If we have to put args on the stack, move %o6==%sp down by
2422 the number of words to go on the stack, to ensure there's enough space.
2424 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2425 16 words above the stack pointer is a word for the address of
2426 a structure return value. I use this as a temporary location
2427 for moving values from float to int regs. Certainly it isn't
2428 safe to put anything in the 16 words starting at %sp, since
2429 this area can get trashed at any time due to window overflows
2430 caused by signal handlers.
2432 A final complication (if the above isn't enough) is that
2433 we can't blithely calculate the arguments one by one into
2434 %o0 .. %o5. Consider the following nested calls:
2438 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2439 the inner call will itself use %o0, which trashes the value put there
2440 in preparation for the outer call. Upshot: we need to calculate the
2441 args into temporary regs, and move those to arg regs or onto the
2442 stack only immediately prior to the call proper. Sigh.
2445 genCCall fn cconv kind args
2446 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2447 let (argcodes, vregss) = unzip argcode_and_vregs
2448 argcode = concatOL argcodes
2449 vregs = concat vregss
2450 n_argRegs = length allArgRegs
2451 n_argRegs_used = min (length vregs) n_argRegs
2452 (move_sp_down, move_sp_up)
2453 = let nn = length vregs - n_argRegs
2454 + 1 -- (for the road)
2457 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2459 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2461 = unitOL (CALL fn__2 n_argRegs_used False)
2463 returnNat (argcode `appOL`
2464 move_sp_down `appOL`
2465 transfer_code `appOL`
2470 -- function names that begin with '.' are assumed to be special
2471 -- internally generated names like '.mul,' which don't get an
2472 -- underscore prefix
2473 -- ToDo:needed (WDP 96/03) ???
2474 fn__2 = case (_HEAD_ fn) of
2475 '.' -> ImmLit (ptext fn)
2476 _ -> ImmLab False (ptext fn)
2478 -- move args from the integer vregs into which they have been
2479 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2480 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2482 move_final [] _ offset -- all args done
2485 move_final (v:vs) [] offset -- out of aregs; move to stack
2486 = ST W v (spRel offset)
2487 : move_final vs [] (offset+1)
2489 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2490 = OR False g0 (RIReg v) a
2491 : move_final vs az offset
2493 -- generate code to calculate an argument, and move it into one
2494 -- or two integer vregs.
2495 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2496 arg_to_int_vregs arg
2497 = getRegister arg `thenNat` \ register ->
2498 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2499 let code = registerCode register tmp
2500 src = registerName register tmp
2501 pk = registerRep register
2503 -- the value is in src. Get it into 1 or 2 int vregs.
2506 getNewRegNCG WordRep `thenNat` \ v1 ->
2507 getNewRegNCG WordRep `thenNat` \ v2 ->
2510 FMOV DF src f0 `snocOL`
2511 ST F f0 (spRel 16) `snocOL`
2512 LD W (spRel 16) v1 `snocOL`
2513 ST F (fPair f0) (spRel 16) `snocOL`
2519 getNewRegNCG WordRep `thenNat` \ v1 ->
2522 ST F src (spRel 16) `snocOL`
2528 getNewRegNCG WordRep `thenNat` \ v1 ->
2530 code `snocOL` OR False g0 (RIReg src) v1
2534 #endif {- sparc_TARGET_ARCH -}
2537 %************************************************************************
2539 \subsection{Support bits}
2541 %************************************************************************
2543 %************************************************************************
2545 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2547 %************************************************************************
2549 Turn those condition codes into integers now (when they appear on
2550 the right hand side of an assignment).
2552 (If applicable) Do not fill the delay slots here; you will confuse the
2556 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2558 #if alpha_TARGET_ARCH
2559 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2560 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2561 #endif {- alpha_TARGET_ARCH -}
2563 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2564 #if i386_TARGET_ARCH
2567 = condIntCode cond x y `thenNat` \ condition ->
2568 getNewRegNCG IntRep `thenNat` \ tmp ->
2570 code = condCode condition
2571 cond = condName condition
2572 code__2 dst = code `appOL` toOL [
2573 SETCC cond (OpReg tmp),
2574 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2575 MOV L (OpReg tmp) (OpReg dst)]
2577 returnNat (Any IntRep code__2)
2580 = getNatLabelNCG `thenNat` \ lbl1 ->
2581 getNatLabelNCG `thenNat` \ lbl2 ->
2582 condFltCode cond x y `thenNat` \ condition ->
2584 code = condCode condition
2585 cond = condName condition
2586 code__2 dst = code `appOL` toOL [
2588 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2591 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2594 returnNat (Any IntRep code__2)
2596 #endif {- i386_TARGET_ARCH -}
2597 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2598 #if sparc_TARGET_ARCH
2600 condIntReg EQQ x (StInt 0)
2601 = getRegister x `thenNat` \ register ->
2602 getNewRegNCG IntRep `thenNat` \ tmp ->
2604 code = registerCode register tmp
2605 src = registerName register tmp
2606 code__2 dst = code `appOL` toOL [
2607 SUB False True g0 (RIReg src) g0,
2608 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2610 returnNat (Any IntRep code__2)
2613 = getRegister x `thenNat` \ register1 ->
2614 getRegister y `thenNat` \ register2 ->
2615 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2616 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2618 code1 = registerCode register1 tmp1
2619 src1 = registerName register1 tmp1
2620 code2 = registerCode register2 tmp2
2621 src2 = registerName register2 tmp2
2622 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2623 XOR False src1 (RIReg src2) dst,
2624 SUB False True g0 (RIReg dst) g0,
2625 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2627 returnNat (Any IntRep code__2)
2629 condIntReg NE x (StInt 0)
2630 = getRegister x `thenNat` \ register ->
2631 getNewRegNCG IntRep `thenNat` \ tmp ->
2633 code = registerCode register tmp
2634 src = registerName register tmp
2635 code__2 dst = code `appOL` toOL [
2636 SUB False True g0 (RIReg src) g0,
2637 ADD True False g0 (RIImm (ImmInt 0)) dst]
2639 returnNat (Any IntRep code__2)
2642 = getRegister x `thenNat` \ register1 ->
2643 getRegister y `thenNat` \ register2 ->
2644 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2645 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2647 code1 = registerCode register1 tmp1
2648 src1 = registerName register1 tmp1
2649 code2 = registerCode register2 tmp2
2650 src2 = registerName register2 tmp2
2651 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2652 XOR False src1 (RIReg src2) dst,
2653 SUB False True g0 (RIReg dst) g0,
2654 ADD True False g0 (RIImm (ImmInt 0)) dst]
2656 returnNat (Any IntRep code__2)
2659 = getNatLabelNCG `thenNat` \ lbl1 ->
2660 getNatLabelNCG `thenNat` \ lbl2 ->
2661 condIntCode cond x y `thenNat` \ condition ->
2663 code = condCode condition
2664 cond = condName condition
2665 code__2 dst = code `appOL` toOL [
2666 BI cond False (ImmCLbl lbl1), NOP,
2667 OR False g0 (RIImm (ImmInt 0)) dst,
2668 BI ALWAYS False (ImmCLbl lbl2), NOP,
2670 OR False g0 (RIImm (ImmInt 1)) dst,
2673 returnNat (Any IntRep code__2)
2676 = getNatLabelNCG `thenNat` \ lbl1 ->
2677 getNatLabelNCG `thenNat` \ lbl2 ->
2678 condFltCode cond x y `thenNat` \ condition ->
2680 code = condCode condition
2681 cond = condName condition
2682 code__2 dst = code `appOL` toOL [
2684 BF cond False (ImmCLbl lbl1), NOP,
2685 OR False g0 (RIImm (ImmInt 0)) dst,
2686 BI ALWAYS False (ImmCLbl lbl2), NOP,
2688 OR False g0 (RIImm (ImmInt 1)) dst,
2691 returnNat (Any IntRep code__2)
2693 #endif {- sparc_TARGET_ARCH -}
2696 %************************************************************************
2698 \subsubsection{@trivial*Code@: deal with trivial instructions}
2700 %************************************************************************
2702 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2703 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2704 for constants on the right hand side, because that's where the generic
2705 optimizer will have put them.
2707 Similarly, for unary instructions, we don't have to worry about
2708 matching an StInt as the argument, because genericOpt will already
2709 have handled the constant-folding.
2713 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2714 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2715 -> Maybe (Operand -> Operand -> Instr)
2716 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2718 -> StixTree -> StixTree -- the two arguments
2723 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2724 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2725 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2727 -> StixTree -> StixTree -- the two arguments
2731 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2732 ,IF_ARCH_i386 ((Operand -> Instr)
2733 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2735 -> StixTree -- the one argument
2740 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2741 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2742 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2744 -> StixTree -- the one argument
2747 #if alpha_TARGET_ARCH
2749 trivialCode instr x (StInt y)
2751 = getRegister x `thenNat` \ register ->
2752 getNewRegNCG IntRep `thenNat` \ tmp ->
2754 code = registerCode register tmp
2755 src1 = registerName register tmp
2756 src2 = ImmInt (fromInteger y)
2757 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2759 returnNat (Any IntRep code__2)
2761 trivialCode instr x y
2762 = getRegister x `thenNat` \ register1 ->
2763 getRegister y `thenNat` \ register2 ->
2764 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2765 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2767 code1 = registerCode register1 tmp1 []
2768 src1 = registerName register1 tmp1
2769 code2 = registerCode register2 tmp2 []
2770 src2 = registerName register2 tmp2
2771 code__2 dst = asmSeqThen [code1, code2] .
2772 mkSeqInstr (instr src1 (RIReg src2) dst)
2774 returnNat (Any IntRep code__2)
2777 trivialUCode instr x
2778 = getRegister x `thenNat` \ register ->
2779 getNewRegNCG IntRep `thenNat` \ tmp ->
2781 code = registerCode register tmp
2782 src = registerName register tmp
2783 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2785 returnNat (Any IntRep code__2)
2788 trivialFCode _ instr x y
2789 = getRegister x `thenNat` \ register1 ->
2790 getRegister y `thenNat` \ register2 ->
2791 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2792 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2794 code1 = registerCode register1 tmp1
2795 src1 = registerName register1 tmp1
2797 code2 = registerCode register2 tmp2
2798 src2 = registerName register2 tmp2
2800 code__2 dst = asmSeqThen [code1 [], code2 []] .
2801 mkSeqInstr (instr src1 src2 dst)
2803 returnNat (Any DoubleRep code__2)
2805 trivialUFCode _ instr x
2806 = getRegister x `thenNat` \ register ->
2807 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2809 code = registerCode register tmp
2810 src = registerName register tmp
2811 code__2 dst = code . mkSeqInstr (instr src dst)
2813 returnNat (Any DoubleRep code__2)
2815 #endif {- alpha_TARGET_ARCH -}
2816 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2817 #if i386_TARGET_ARCH
2819 The Rules of the Game are:
2821 * You cannot assume anything about the destination register dst;
2822 it may be anything, including a fixed reg.
2824 * You may compute an operand into a fixed reg, but you may not
2825 subsequently change the contents of that fixed reg. If you
2826 want to do so, first copy the value either to a temporary
2827 or into dst. You are free to modify dst even if it happens
2828 to be a fixed reg -- that's not your problem.
2830 * You cannot assume that a fixed reg will stay live over an
2831 arbitrary computation. The same applies to the dst reg.
2833 * Temporary regs obtained from getNewRegNCG are distinct from
2834 each other and from all other regs, and stay live over
2835 arbitrary computations.
2839 trivialCode instr maybe_revinstr a b
2842 = getRegister a `thenNat` \ rega ->
2845 then registerCode rega dst `bind` \ code_a ->
2847 instr (OpImm imm_b) (OpReg dst)
2848 else registerCodeF rega `bind` \ code_a ->
2849 registerNameF rega `bind` \ r_a ->
2851 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2852 instr (OpImm imm_b) (OpReg dst)
2854 returnNat (Any IntRep mkcode)
2857 = getRegister b `thenNat` \ regb ->
2858 getNewRegNCG IntRep `thenNat` \ tmp ->
2859 let revinstr_avail = maybeToBool maybe_revinstr
2860 revinstr = case maybe_revinstr of Just ri -> ri
2864 then registerCode regb dst `bind` \ code_b ->
2866 revinstr (OpImm imm_a) (OpReg dst)
2867 else registerCodeF regb `bind` \ code_b ->
2868 registerNameF regb `bind` \ r_b ->
2870 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2871 revinstr (OpImm imm_a) (OpReg dst)
2875 then registerCode regb tmp `bind` \ code_b ->
2877 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2878 instr (OpReg tmp) (OpReg dst)
2879 else registerCodeF regb `bind` \ code_b ->
2880 registerNameF regb `bind` \ r_b ->
2882 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2883 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2884 instr (OpReg tmp) (OpReg dst)
2886 returnNat (Any IntRep mkcode)
2889 = getRegister a `thenNat` \ rega ->
2890 getRegister b `thenNat` \ regb ->
2891 getNewRegNCG IntRep `thenNat` \ tmp ->
2893 = case (isAny rega, isAny regb) of
2895 -> registerCode regb tmp `bind` \ code_b ->
2896 registerCode rega dst `bind` \ code_a ->
2899 instr (OpReg tmp) (OpReg dst)
2901 -> registerCode rega tmp `bind` \ code_a ->
2902 registerCodeF regb `bind` \ code_b ->
2903 registerNameF regb `bind` \ r_b ->
2906 instr (OpReg r_b) (OpReg tmp) `snocOL`
2907 MOV L (OpReg tmp) (OpReg dst)
2909 -> registerCode regb tmp `bind` \ code_b ->
2910 registerCodeF rega `bind` \ code_a ->
2911 registerNameF rega `bind` \ r_a ->
2914 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2915 instr (OpReg tmp) (OpReg dst)
2917 -> registerCodeF rega `bind` \ code_a ->
2918 registerNameF rega `bind` \ r_a ->
2919 registerCodeF regb `bind` \ code_b ->
2920 registerNameF regb `bind` \ r_b ->
2922 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2924 instr (OpReg r_b) (OpReg tmp) `snocOL`
2925 MOV L (OpReg tmp) (OpReg dst)
2927 returnNat (Any IntRep mkcode)
2930 maybe_imm_a = maybeImm a
2931 is_imm_a = maybeToBool maybe_imm_a
2932 imm_a = case maybe_imm_a of Just imm -> imm
2934 maybe_imm_b = maybeImm b
2935 is_imm_b = maybeToBool maybe_imm_b
2936 imm_b = case maybe_imm_b of Just imm -> imm
2940 trivialUCode instr x
2941 = getRegister x `thenNat` \ register ->
2943 code__2 dst = let code = registerCode register dst
2944 src = registerName register dst
2946 if isFixed register && dst /= src
2947 then toOL [MOV L (OpReg src) (OpReg dst),
2949 else unitOL (instr (OpReg src))
2951 returnNat (Any IntRep code__2)
2954 trivialFCode pk instr x y
2955 = getRegister x `thenNat` \ register1 ->
2956 getRegister y `thenNat` \ register2 ->
2957 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2958 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2960 code1 = registerCode register1 tmp1
2961 src1 = registerName register1 tmp1
2963 code2 = registerCode register2 tmp2
2964 src2 = registerName register2 tmp2
2967 -- treat the common case specially: both operands in
2969 | isAny register1 && isAny register2
2972 instr (primRepToSize pk) src1 src2 dst
2974 -- be paranoid (and inefficient)
2976 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2978 instr (primRepToSize pk) tmp1 src2 dst
2980 returnNat (Any pk code__2)
2984 trivialUFCode pk instr x
2985 = getRegister x `thenNat` \ register ->
2986 getNewRegNCG pk `thenNat` \ tmp ->
2988 code = registerCode register tmp
2989 src = registerName register tmp
2990 code__2 dst = code `snocOL` instr src dst
2992 returnNat (Any pk code__2)
2994 #endif {- i386_TARGET_ARCH -}
2995 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2996 #if sparc_TARGET_ARCH
2998 trivialCode instr x (StInt y)
3000 = getRegister x `thenNat` \ register ->
3001 getNewRegNCG IntRep `thenNat` \ tmp ->
3003 code = registerCode register tmp
3004 src1 = registerName register tmp
3005 src2 = ImmInt (fromInteger y)
3006 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3008 returnNat (Any IntRep code__2)
3010 trivialCode instr x y
3011 = getRegister x `thenNat` \ register1 ->
3012 getRegister y `thenNat` \ register2 ->
3013 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3014 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3016 code1 = registerCode register1 tmp1
3017 src1 = registerName register1 tmp1
3018 code2 = registerCode register2 tmp2
3019 src2 = registerName register2 tmp2
3020 code__2 dst = code1 `appOL` code2 `snocOL`
3021 instr src1 (RIReg src2) dst
3023 returnNat (Any IntRep code__2)
3026 trivialFCode pk instr x y
3027 = getRegister x `thenNat` \ register1 ->
3028 getRegister y `thenNat` \ register2 ->
3029 getNewRegNCG (registerRep register1)
3031 getNewRegNCG (registerRep register2)
3033 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3035 promote x = FxTOy F DF x tmp
3037 pk1 = registerRep register1
3038 code1 = registerCode register1 tmp1
3039 src1 = registerName register1 tmp1
3041 pk2 = registerRep register2
3042 code2 = registerCode register2 tmp2
3043 src2 = registerName register2 tmp2
3047 code1 `appOL` code2 `snocOL`
3048 instr (primRepToSize pk) src1 src2 dst
3049 else if pk1 == FloatRep then
3050 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3051 instr DF tmp src2 dst
3053 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3054 instr DF src1 tmp dst
3056 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3059 trivialUCode instr x
3060 = getRegister x `thenNat` \ register ->
3061 getNewRegNCG IntRep `thenNat` \ tmp ->
3063 code = registerCode register tmp
3064 src = registerName register tmp
3065 code__2 dst = code `snocOL` instr (RIReg src) dst
3067 returnNat (Any IntRep code__2)
3070 trivialUFCode pk instr x
3071 = getRegister x `thenNat` \ register ->
3072 getNewRegNCG pk `thenNat` \ tmp ->
3074 code = registerCode register tmp
3075 src = registerName register tmp
3076 code__2 dst = code `snocOL` instr src dst
3078 returnNat (Any pk code__2)
3080 #endif {- sparc_TARGET_ARCH -}
3083 %************************************************************************
3085 \subsubsection{Coercing to/from integer/floating-point...}
3087 %************************************************************************
3089 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3090 to be generated. Here we just change the type on the Register passed
3091 on up. The code is machine-independent.
3093 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3094 conversions. We have to store temporaries in memory to move
3095 between the integer and the floating point register sets.
3098 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3099 coerceFltCode :: StixTree -> NatM Register
3101 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3102 coerceFP2Int :: StixTree -> NatM Register
3105 = getRegister x `thenNat` \ register ->
3108 Fixed _ reg code -> Fixed pk reg code
3109 Any _ code -> Any pk code
3114 = getRegister x `thenNat` \ register ->
3117 Fixed _ reg code -> Fixed DoubleRep reg code
3118 Any _ code -> Any DoubleRep code
3123 #if alpha_TARGET_ARCH
3126 = getRegister x `thenNat` \ register ->
3127 getNewRegNCG IntRep `thenNat` \ reg ->
3129 code = registerCode register reg
3130 src = registerName register reg
3132 code__2 dst = code . mkSeqInstrs [
3134 LD TF dst (spRel 0),
3137 returnNat (Any DoubleRep code__2)
3141 = getRegister x `thenNat` \ register ->
3142 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3144 code = registerCode register tmp
3145 src = registerName register tmp
3147 code__2 dst = code . mkSeqInstrs [
3149 ST TF tmp (spRel 0),
3152 returnNat (Any IntRep code__2)
3154 #endif {- alpha_TARGET_ARCH -}
3155 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3156 #if i386_TARGET_ARCH
3159 = getRegister x `thenNat` \ register ->
3160 getNewRegNCG IntRep `thenNat` \ reg ->
3162 code = registerCode register reg
3163 src = registerName register reg
3164 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3165 code__2 dst = code `snocOL` opc src dst
3167 returnNat (Any pk code__2)
3171 = getRegister x `thenNat` \ register ->
3172 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3174 code = registerCode register tmp
3175 src = registerName register tmp
3176 pk = registerRep register
3178 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3179 code__2 dst = code `snocOL` opc src dst
3181 returnNat (Any IntRep code__2)
3183 #endif {- i386_TARGET_ARCH -}
3184 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3185 #if sparc_TARGET_ARCH
3188 = getRegister x `thenNat` \ register ->
3189 getNewRegNCG IntRep `thenNat` \ reg ->
3191 code = registerCode register reg
3192 src = registerName register reg
3194 code__2 dst = code `appOL` toOL [
3195 ST W src (spRel (-2)),
3196 LD W (spRel (-2)) dst,
3197 FxTOy W (primRepToSize pk) dst dst]
3199 returnNat (Any pk code__2)
3203 = getRegister x `thenNat` \ register ->
3204 getNewRegNCG IntRep `thenNat` \ reg ->
3205 getNewRegNCG FloatRep `thenNat` \ tmp ->
3207 code = registerCode register reg
3208 src = registerName register reg
3209 pk = registerRep register
3211 code__2 dst = code `appOL` toOL [
3212 FxTOy (primRepToSize pk) W src tmp,
3213 ST W tmp (spRel (-2)),
3214 LD W (spRel (-2)) dst]
3216 returnNat (Any IntRep code__2)
3218 #endif {- sparc_TARGET_ARCH -}
3221 %************************************************************************
3223 \subsubsection{Coercing integer to @Char@...}
3225 %************************************************************************
3227 Integer to character conversion.
3230 chrCode :: StixTree -> NatM Register
3232 #if alpha_TARGET_ARCH
3234 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3235 -- It should coerce a 64-bit value to a 32-bit value.
3238 = getRegister x `thenNat` \ register ->
3239 getNewRegNCG IntRep `thenNat` \ reg ->
3241 code = registerCode register reg
3242 src = registerName register reg
3243 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3245 returnNat (Any IntRep code__2)
3247 #endif {- alpha_TARGET_ARCH -}
3248 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3249 #if i386_TARGET_ARCH
3252 = getRegister x `thenNat` \ register ->
3255 Fixed _ reg code -> Fixed IntRep reg code
3256 Any _ code -> Any IntRep code
3259 #endif {- i386_TARGET_ARCH -}
3260 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3261 #if sparc_TARGET_ARCH
3264 = getRegister x `thenNat` \ register ->
3267 Fixed _ reg code -> Fixed IntRep reg code
3268 Any _ code -> Any IntRep code
3271 #endif {- sparc_TARGET_ARCH -}