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 ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import Unique ( Unique )
18 import MachMisc -- may differ per-platform
20 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
21 snocOL, consOL, concatOL )
22 import MachOp ( MachOp(..), pprMachOp )
23 import AbsCUtils ( magicIdPrimRep )
24 import PprAbsC ( pprMagicId )
25 import ForeignCall ( CCallConv(..) )
26 import CLabel ( CLabel, labelDynamic )
27 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
28 import CLabel ( isAsmTemp )
30 import Maybes ( maybeToBool )
31 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
32 getPrimRepArrayElemSize )
33 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
34 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
35 DestInfo, hasDestInfo,
36 pprStixExpr, repOfStixExpr,
38 NatM, thenNat, returnNat, mapNat,
39 mapAndUnzipNat, mapAccumLNat,
40 getDeltaNat, setDeltaNat, getUniqueNat,
45 import Outputable ( panic, pprPanic, showSDoc )
46 import qualified Outputable
47 import CmdLineOpts ( opt_Static )
48 import Stix ( pprStixStmt )
51 import IOExts ( trace )
56 @InstrBlock@s are the insn sequences generated by the insn selectors.
57 They are really trees of insns to facilitate fast appending, where a
58 left-to-right traversal (pre-order?) yields the insns in the correct
62 type InstrBlock = OrdList Instr
67 Code extractor for an entire stix tree---stix statement level.
70 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
72 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
73 returnNat (concatOL instrss)
76 stmtToInstrs :: StixStmt -> NatM InstrBlock
77 stmtToInstrs stmt = case stmt of
78 StComment s -> returnNat (unitOL (COMMENT s))
79 StSegment seg -> returnNat (unitOL (SEGMENT seg))
81 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
83 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
86 StLabel lab -> returnNat (unitOL (LABEL lab))
88 StJump dsts arg -> genJump dsts (derefDLL arg)
89 StCondJump lab arg -> genCondJump lab (derefDLL arg)
91 -- A call returning void, ie one done for its side-effects. Note
92 -- that this is the only StVoidable we handle.
93 StVoidable (StCall fn cconv VoidRep args)
94 -> genCCall fn cconv VoidRep (map derefDLL args)
96 StAssignMem pk addr src
97 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
99 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
100 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
101 StAssignReg pk reg src
102 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
103 | ncg_target_is_32bit
104 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
105 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
108 -- When falling through on the Alpha, we still have to load pv
109 -- with the address of the next routine, so that it can load gp.
110 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
114 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
115 returnNat (DATA (primRepToSize kind) imms
116 `consOL` concatOL codes)
118 getData :: StixExpr -> NatM (InstrBlock, Imm)
119 getData (StInt i) = returnNat (nilOL, ImmInteger i)
120 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
121 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
122 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
123 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
124 -- the linker can handle simple arithmetic...
125 getData (StIndex rep (StCLbl lbl) (StInt off)) =
127 ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
129 -- Top-level lifted-out string. The segment will already have been set
130 -- (see Stix.liftStrings).
132 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
135 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
138 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
139 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
140 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
142 derefDLL :: StixExpr -> StixExpr
144 | opt_Static -- short out the entire deal if not doing DLLs
151 StCLbl lbl -> if labelDynamic lbl
152 then StInd PtrRep (StCLbl lbl)
154 -- all the rest are boring
155 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
156 StMachOp mop args -> StMachOp mop (map qq args)
157 StInd pk addr -> StInd pk (qq addr)
158 StCall who cc pk args -> StCall who cc pk (map qq args)
164 _ -> pprPanic "derefDLL: unhandled case"
168 %************************************************************************
170 \subsection{General things for putting together code sequences}
172 %************************************************************************
175 mangleIndexTree :: StixExpr -> StixExpr
177 mangleIndexTree (StIndex pk base (StInt i))
178 = StMachOp MO_Nat_Add [base, off]
180 off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
182 mangleIndexTree (StIndex pk base off)
183 = StMachOp MO_Nat_Add [
186 in if s == 0 then off
187 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
190 shift :: PrimRep -> Int
191 shift rep = case getPrimRepArrayElemSize rep of
196 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
197 (Outputable.int other)
201 maybeImm :: StixExpr -> Maybe Imm
205 maybeImm (StIndex rep (StCLbl l) (StInt off))
206 = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
208 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
209 = Just (ImmInt (fromInteger i))
211 = Just (ImmInteger i)
216 %************************************************************************
218 \subsection{The @Register64@ type}
220 %************************************************************************
222 Simple support for generating 64-bit code (ie, 64 bit values and 64
223 bit assignments) on 32-bit platforms. Unlike the main code generator
224 we merely shoot for generating working code as simply as possible, and
225 pay little attention to code quality. Specifically, there is no
226 attempt to deal cleverly with the fixed-vs-floating register
227 distinction; all values are generated into (pairs of) floating
228 registers, even if this would mean some redundant reg-reg moves as a
229 result. Only one of the VRegUniques is returned, since it will be
230 of the VRegUniqueLo form, and the upper-half VReg can be determined
231 by applying getHiVRegFromLo to it.
235 data ChildCode64 -- a.k.a "Register64"
238 VRegUnique -- unique for the lower 32-bit temporary
239 -- which contains the result; use getHiVRegFromLo to find
240 -- the other VRegUnique.
241 -- Rules of this simplified insn selection game are
242 -- therefore that the returned VRegUnique may be modified
244 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
245 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
246 iselExpr64 :: StixExpr -> NatM ChildCode64
248 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
252 assignMem_I64Code addrTree valueTree
253 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
254 getRegister addrTree `thenNat` \ register_addr ->
255 getNewRegNCG IntRep `thenNat` \ t_addr ->
256 let rlo = VirtualRegI vrlo
257 rhi = getHiVRegFromLo rlo
258 code_addr = registerCode register_addr t_addr
259 reg_addr = registerName register_addr t_addr
260 -- Little-endian store
261 mov_lo = MOV L (OpReg rlo)
262 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
263 mov_hi = MOV L (OpReg rhi)
264 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
266 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
268 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
269 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
271 r_dst_lo = mkVReg u_dst IntRep
272 r_src_lo = VirtualRegI vr_src_lo
273 r_dst_hi = getHiVRegFromLo r_dst_lo
274 r_src_hi = getHiVRegFromLo r_src_lo
275 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
276 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
279 vcode `snocOL` mov_lo `snocOL` mov_hi
282 assignReg_I64Code lvalue valueTree
283 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
288 iselExpr64 (StInd pk addrTree)
290 = getRegister addrTree `thenNat` \ register_addr ->
291 getNewRegNCG IntRep `thenNat` \ t_addr ->
292 getNewRegNCG IntRep `thenNat` \ rlo ->
293 let rhi = getHiVRegFromLo rlo
294 code_addr = registerCode register_addr t_addr
295 reg_addr = registerName register_addr t_addr
296 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
298 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
302 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
306 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
308 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
309 let r_dst_hi = getHiVRegFromLo r_dst_lo
310 r_src_lo = mkVReg vu IntRep
311 r_src_hi = getHiVRegFromLo r_src_lo
312 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
313 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
316 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
319 iselExpr64 (StCall fn cconv kind args)
321 = genCCall fn cconv kind args `thenNat` \ call ->
322 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
323 let r_dst_hi = getHiVRegFromLo r_dst_lo
324 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
325 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
328 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
329 (getVRegUnique r_dst_lo)
333 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
335 #endif {- i386_TARGET_ARCH -}
337 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
339 #if sparc_TARGET_ARCH
341 assignMem_I64Code addrTree valueTree
342 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
343 getRegister addrTree `thenNat` \ register_addr ->
344 getNewRegNCG IntRep `thenNat` \ t_addr ->
345 let rlo = VirtualRegI vrlo
346 rhi = getHiVRegFromLo rlo
347 code_addr = registerCode register_addr t_addr
348 reg_addr = registerName register_addr t_addr
350 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
351 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
353 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
356 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
357 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
359 r_dst_lo = mkVReg u_dst IntRep
360 r_src_lo = VirtualRegI vr_src_lo
361 r_dst_hi = getHiVRegFromLo r_dst_lo
362 r_src_hi = getHiVRegFromLo r_src_lo
363 mov_lo = mkMOV r_src_lo r_dst_lo
364 mov_hi = mkMOV r_src_hi r_dst_hi
365 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
368 vcode `snocOL` mov_hi `snocOL` mov_lo
370 assignReg_I64Code lvalue valueTree
371 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
375 -- Don't delete this -- it's very handy for debugging.
377 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
378 -- = panic "iselExpr64(???)"
380 iselExpr64 (StInd pk addrTree)
382 = getRegister addrTree `thenNat` \ register_addr ->
383 getNewRegNCG IntRep `thenNat` \ t_addr ->
384 getNewRegNCG IntRep `thenNat` \ rlo ->
385 let rhi = getHiVRegFromLo rlo
386 code_addr = registerCode register_addr t_addr
387 reg_addr = registerName register_addr t_addr
388 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
389 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
392 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
396 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
398 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
399 let r_dst_hi = getHiVRegFromLo r_dst_lo
400 r_src_lo = mkVReg vu IntRep
401 r_src_hi = getHiVRegFromLo r_src_lo
402 mov_lo = mkMOV r_src_lo r_dst_lo
403 mov_hi = mkMOV r_src_hi r_dst_hi
404 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
407 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
410 iselExpr64 (StCall fn cconv kind args)
412 = genCCall fn cconv kind args `thenNat` \ call ->
413 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
414 let r_dst_hi = getHiVRegFromLo r_dst_lo
415 mov_lo = mkMOV o0 r_dst_lo
416 mov_hi = mkMOV o1 r_dst_hi
417 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
420 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
421 (getVRegUnique r_dst_lo)
425 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
427 #endif {- sparc_TARGET_ARCH -}
429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
433 %************************************************************************
435 \subsection{The @Register@ type}
437 %************************************************************************
439 @Register@s passed up the tree. If the stix code forces the register
440 to live in a pre-decided machine register, it comes out as @Fixed@;
441 otherwise, it comes out as @Any@, and the parent can decide which
442 register to put it in.
446 = Fixed PrimRep Reg InstrBlock
447 | Any PrimRep (Reg -> InstrBlock)
449 registerCode :: Register -> Reg -> InstrBlock
450 registerCode (Fixed _ _ code) reg = code
451 registerCode (Any _ code) reg = code reg
453 registerCodeF (Fixed _ _ code) = code
454 registerCodeF (Any _ _) = panic "registerCodeF"
456 registerCodeA (Any _ code) = code
457 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
459 registerName :: Register -> Reg -> Reg
460 registerName (Fixed _ reg _) _ = reg
461 registerName (Any _ _) reg = reg
463 registerNameF (Fixed _ reg _) = reg
464 registerNameF (Any _ _) = panic "registerNameF"
466 registerRep :: Register -> PrimRep
467 registerRep (Fixed pk _ _) = pk
468 registerRep (Any pk _) = pk
470 swizzleRegisterRep :: Register -> PrimRep -> Register
471 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
472 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
474 {-# INLINE registerCode #-}
475 {-# INLINE registerCodeF #-}
476 {-# INLINE registerName #-}
477 {-# INLINE registerNameF #-}
478 {-# INLINE registerRep #-}
479 {-# INLINE isFixed #-}
482 isFixed, isAny :: Register -> Bool
483 isFixed (Fixed _ _ _) = True
484 isFixed (Any _ _) = False
486 isAny = not . isFixed
489 Generate code to get a subtree into a @Register@:
492 getRegisterReg :: StixReg -> NatM Register
493 getRegister :: StixExpr -> NatM Register
496 getRegisterReg (StixMagicId mid)
497 = case get_MagicId_reg_or_addr mid of
499 -> let pk = magicIdPrimRep mid
500 in returnNat (Fixed pk (RealReg rrno) nilOL)
502 -- By this stage, the only MagicIds remaining should be the
503 -- ones which map to a real machine register on this platform. Hence ...
504 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
506 getRegisterReg (StixTemp (StixVReg u pk))
507 = returnNat (Fixed pk (mkVReg u pk) nilOL)
511 -- Don't delete this -- it's very handy for debugging.
513 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
514 -- = panic "getRegister(???)"
516 getRegister (StReg reg)
519 getRegister tree@(StIndex _ _ _)
520 = getRegister (mangleIndexTree tree)
522 getRegister (StCall fn cconv kind args)
523 | not (ncg_target_is_32bit && is64BitRep kind)
524 = genCCall fn cconv kind args `thenNat` \ call ->
525 returnNat (Fixed kind reg call)
527 reg = if isFloatingRep kind
528 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
529 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
531 getRegister (StString s)
532 = getNatLabelNCG `thenNat` \ lbl ->
534 imm_lbl = ImmCLbl lbl
537 SEGMENT RoDataSegment,
539 ASCII True (_UNPK_ s),
541 #if alpha_TARGET_ARCH
542 LDA dst (AddrImm imm_lbl)
545 MOV L (OpImm imm_lbl) (OpReg dst)
547 #if sparc_TARGET_ARCH
548 SETHI (HI imm_lbl) dst,
549 OR False dst (RIImm (LO imm_lbl)) dst
553 returnNat (Any PtrRep code)
555 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
556 -- end of machine-"independent" bit; here we go on the rest...
558 #if alpha_TARGET_ARCH
560 getRegister (StDouble d)
561 = getNatLabelNCG `thenNat` \ lbl ->
562 getNewRegNCG PtrRep `thenNat` \ tmp ->
563 let code dst = mkSeqInstrs [
566 DATA TF [ImmLab (rational d)],
568 LDA tmp (AddrImm (ImmCLbl lbl)),
569 LD TF dst (AddrReg tmp)]
571 returnNat (Any DoubleRep code)
573 getRegister (StPrim primop [x]) -- unary PrimOps
575 IntNegOp -> trivialUCode (NEG Q False) x
577 NotOp -> trivialUCode NOT x
579 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
580 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
582 OrdOp -> coerceIntCode IntRep x
585 Float2IntOp -> coerceFP2Int x
586 Int2FloatOp -> coerceInt2FP pr x
587 Double2IntOp -> coerceFP2Int x
588 Int2DoubleOp -> coerceInt2FP pr x
590 Double2FloatOp -> coerceFltCode x
591 Float2DoubleOp -> coerceFltCode x
593 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
595 fn = case other_op of
596 FloatExpOp -> SLIT("exp")
597 FloatLogOp -> SLIT("log")
598 FloatSqrtOp -> SLIT("sqrt")
599 FloatSinOp -> SLIT("sin")
600 FloatCosOp -> SLIT("cos")
601 FloatTanOp -> SLIT("tan")
602 FloatAsinOp -> SLIT("asin")
603 FloatAcosOp -> SLIT("acos")
604 FloatAtanOp -> SLIT("atan")
605 FloatSinhOp -> SLIT("sinh")
606 FloatCoshOp -> SLIT("cosh")
607 FloatTanhOp -> SLIT("tanh")
608 DoubleExpOp -> SLIT("exp")
609 DoubleLogOp -> SLIT("log")
610 DoubleSqrtOp -> SLIT("sqrt")
611 DoubleSinOp -> SLIT("sin")
612 DoubleCosOp -> SLIT("cos")
613 DoubleTanOp -> SLIT("tan")
614 DoubleAsinOp -> SLIT("asin")
615 DoubleAcosOp -> SLIT("acos")
616 DoubleAtanOp -> SLIT("atan")
617 DoubleSinhOp -> SLIT("sinh")
618 DoubleCoshOp -> SLIT("cosh")
619 DoubleTanhOp -> SLIT("tanh")
621 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
623 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
625 CharGtOp -> trivialCode (CMP LTT) y x
626 CharGeOp -> trivialCode (CMP LE) y x
627 CharEqOp -> trivialCode (CMP EQQ) x y
628 CharNeOp -> int_NE_code x y
629 CharLtOp -> trivialCode (CMP LTT) x y
630 CharLeOp -> trivialCode (CMP LE) x y
632 IntGtOp -> trivialCode (CMP LTT) y x
633 IntGeOp -> trivialCode (CMP LE) y x
634 IntEqOp -> trivialCode (CMP EQQ) x y
635 IntNeOp -> int_NE_code x y
636 IntLtOp -> trivialCode (CMP LTT) x y
637 IntLeOp -> trivialCode (CMP LE) x y
639 WordGtOp -> trivialCode (CMP ULT) y x
640 WordGeOp -> trivialCode (CMP ULE) x y
641 WordEqOp -> trivialCode (CMP EQQ) x y
642 WordNeOp -> int_NE_code x y
643 WordLtOp -> trivialCode (CMP ULT) x y
644 WordLeOp -> trivialCode (CMP ULE) x y
646 AddrGtOp -> trivialCode (CMP ULT) y x
647 AddrGeOp -> trivialCode (CMP ULE) y x
648 AddrEqOp -> trivialCode (CMP EQQ) x y
649 AddrNeOp -> int_NE_code x y
650 AddrLtOp -> trivialCode (CMP ULT) x y
651 AddrLeOp -> trivialCode (CMP ULE) x y
653 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
654 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
655 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
656 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
657 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
658 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
660 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
661 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
662 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
663 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
664 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
665 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
667 IntAddOp -> trivialCode (ADD Q False) x y
668 IntSubOp -> trivialCode (SUB Q False) x y
669 IntMulOp -> trivialCode (MUL Q False) x y
670 IntQuotOp -> trivialCode (DIV Q False) x y
671 IntRemOp -> trivialCode (REM Q False) x y
673 WordAddOp -> trivialCode (ADD Q False) x y
674 WordSubOp -> trivialCode (SUB Q False) x y
675 WordMulOp -> trivialCode (MUL Q False) x y
676 WordQuotOp -> trivialCode (DIV Q True) x y
677 WordRemOp -> trivialCode (REM Q True) x y
679 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
680 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
681 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
682 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
684 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
685 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
686 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
687 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
689 AddrAddOp -> trivialCode (ADD Q False) x y
690 AddrSubOp -> trivialCode (SUB Q False) x y
691 AddrRemOp -> trivialCode (REM Q True) x y
693 AndOp -> trivialCode AND x y
694 OrOp -> trivialCode OR x y
695 XorOp -> trivialCode XOR x y
696 SllOp -> trivialCode SLL x y
697 SrlOp -> trivialCode SRL x y
699 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
700 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
701 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
703 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
704 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
706 {- ------------------------------------------------------------
707 Some bizarre special code for getting condition codes into
708 registers. Integer non-equality is a test for equality
709 followed by an XOR with 1. (Integer comparisons always set
710 the result register to 0 or 1.) Floating point comparisons of
711 any kind leave the result in a floating point register, so we
712 need to wrangle an integer register out of things.
714 int_NE_code :: StixTree -> StixTree -> NatM Register
717 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
718 getNewRegNCG IntRep `thenNat` \ tmp ->
720 code = registerCode register tmp
721 src = registerName register tmp
722 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
724 returnNat (Any IntRep code__2)
726 {- ------------------------------------------------------------
727 Comments for int_NE_code also apply to cmpF_code
730 :: (Reg -> Reg -> Reg -> Instr)
732 -> StixTree -> StixTree
735 cmpF_code instr cond x y
736 = trivialFCode pr instr x y `thenNat` \ register ->
737 getNewRegNCG DoubleRep `thenNat` \ tmp ->
738 getNatLabelNCG `thenNat` \ lbl ->
740 code = registerCode register tmp
741 result = registerName register tmp
743 code__2 dst = code . mkSeqInstrs [
744 OR zeroh (RIImm (ImmInt 1)) dst,
745 BF cond result (ImmCLbl lbl),
746 OR zeroh (RIReg zeroh) dst,
749 returnNat (Any IntRep code__2)
751 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
752 ------------------------------------------------------------
754 getRegister (StInd pk mem)
755 = getAmode mem `thenNat` \ amode ->
757 code = amodeCode amode
758 src = amodeAddr amode
759 size = primRepToSize pk
760 code__2 dst = code . mkSeqInstr (LD size dst src)
762 returnNat (Any pk code__2)
764 getRegister (StInt i)
767 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
769 returnNat (Any IntRep code)
772 code dst = mkSeqInstr (LDI Q dst src)
774 returnNat (Any IntRep code)
776 src = ImmInt (fromInteger i)
781 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
783 returnNat (Any PtrRep code)
786 imm__2 = case imm of Just x -> x
788 #endif {- alpha_TARGET_ARCH -}
790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
794 getRegister (StFloat f)
795 = getNatLabelNCG `thenNat` \ lbl ->
796 let code dst = toOL [
801 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
804 returnNat (Any FloatRep code)
807 getRegister (StDouble d)
810 = let code dst = unitOL (GLDZ dst)
811 in returnNat (Any DoubleRep code)
814 = let code dst = unitOL (GLD1 dst)
815 in returnNat (Any DoubleRep code)
818 = getNatLabelNCG `thenNat` \ lbl ->
819 let code dst = toOL [
822 DATA DF [ImmDouble d],
824 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
827 returnNat (Any DoubleRep code)
830 getRegister (StMachOp mop [x]) -- unary MachOps
832 MO_NatS_Neg -> trivialUCode (NEGI L) x
833 MO_Nat_Not -> trivialUCode (NOT L) x
835 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
836 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
838 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
839 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
841 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
842 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
844 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
845 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
847 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
848 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
850 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
851 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
852 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
853 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
855 -- Conversions which are a nop on x86
856 MO_NatS_to_32U -> conversionNop WordRep x
857 MO_32U_to_NatS -> conversionNop IntRep x
859 MO_NatU_to_NatS -> conversionNop IntRep x
860 MO_NatS_to_NatU -> conversionNop WordRep x
861 MO_NatP_to_NatU -> conversionNop WordRep x
862 MO_NatU_to_NatP -> conversionNop PtrRep x
863 MO_NatS_to_NatP -> conversionNop PtrRep x
864 MO_NatP_to_NatS -> conversionNop IntRep x
866 MO_Dbl_to_Flt -> conversionNop FloatRep x
867 MO_Flt_to_Dbl -> conversionNop DoubleRep x
869 -- sign-extending widenings
870 MO_8U_to_NatU -> integerExtend False 24 x
871 MO_8S_to_NatS -> integerExtend True 24 x
872 MO_16U_to_NatU -> integerExtend False 16 x
873 MO_16S_to_NatS -> integerExtend True 16 x
877 (if is_float_op then demote else id)
878 (StCall fn CCallConv DoubleRep
879 [(if is_float_op then promote else id) x])
882 integerExtend signed nBits x
884 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
885 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
888 conversionNop new_rep expr
889 = getRegister expr `thenNat` \ e_code ->
890 returnNat (swizzleRegisterRep e_code new_rep)
892 promote x = StMachOp MO_Flt_to_Dbl [x]
893 demote x = StMachOp MO_Dbl_to_Flt [x]
896 MO_Flt_Exp -> (True, SLIT("exp"))
897 MO_Flt_Log -> (True, SLIT("log"))
899 MO_Flt_Asin -> (True, SLIT("asin"))
900 MO_Flt_Acos -> (True, SLIT("acos"))
901 MO_Flt_Atan -> (True, SLIT("atan"))
903 MO_Flt_Sinh -> (True, SLIT("sinh"))
904 MO_Flt_Cosh -> (True, SLIT("cosh"))
905 MO_Flt_Tanh -> (True, SLIT("tanh"))
907 MO_Dbl_Exp -> (False, SLIT("exp"))
908 MO_Dbl_Log -> (False, SLIT("log"))
910 MO_Dbl_Asin -> (False, SLIT("asin"))
911 MO_Dbl_Acos -> (False, SLIT("acos"))
912 MO_Dbl_Atan -> (False, SLIT("atan"))
914 MO_Dbl_Sinh -> (False, SLIT("sinh"))
915 MO_Dbl_Cosh -> (False, SLIT("cosh"))
916 MO_Dbl_Tanh -> (False, SLIT("tanh"))
918 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
922 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
924 MO_32U_Gt -> condIntReg GTT x y
925 MO_32U_Ge -> condIntReg GE x y
926 MO_32U_Eq -> condIntReg EQQ x y
927 MO_32U_Ne -> condIntReg NE x y
928 MO_32U_Lt -> condIntReg LTT x y
929 MO_32U_Le -> condIntReg LE x y
931 MO_Nat_Eq -> condIntReg EQQ x y
932 MO_Nat_Ne -> condIntReg NE x y
934 MO_NatS_Gt -> condIntReg GTT x y
935 MO_NatS_Ge -> condIntReg GE x y
936 MO_NatS_Lt -> condIntReg LTT x y
937 MO_NatS_Le -> condIntReg LE x y
939 MO_NatU_Gt -> condIntReg GU x y
940 MO_NatU_Ge -> condIntReg GEU x y
941 MO_NatU_Lt -> condIntReg LU x y
942 MO_NatU_Le -> condIntReg LEU x y
944 MO_Flt_Gt -> condFltReg GTT x y
945 MO_Flt_Ge -> condFltReg GE x y
946 MO_Flt_Eq -> condFltReg EQQ x y
947 MO_Flt_Ne -> condFltReg NE x y
948 MO_Flt_Lt -> condFltReg LTT x y
949 MO_Flt_Le -> condFltReg LE x y
951 MO_Dbl_Gt -> condFltReg GTT x y
952 MO_Dbl_Ge -> condFltReg GE x y
953 MO_Dbl_Eq -> condFltReg EQQ x y
954 MO_Dbl_Ne -> condFltReg NE x y
955 MO_Dbl_Lt -> condFltReg LTT x y
956 MO_Dbl_Le -> condFltReg LE x y
958 MO_Nat_Add -> add_code L x y
959 MO_Nat_Sub -> sub_code L x y
960 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
961 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
962 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
963 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
964 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
965 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
966 MO_NatS_MulMayOflo -> imulMayOflo x y
968 MO_Flt_Add -> trivialFCode FloatRep GADD x y
969 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
970 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
971 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
973 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
974 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
975 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
976 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
978 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
979 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
980 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
982 {- Shift ops on x86s have constraints on their source, it
983 either has to be Imm, CL or 1
984 => trivialCode's is not restrictive enough (sigh.)
986 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
987 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
988 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
990 MO_Flt_Pwr -> getRegister (demote
991 (StCall SLIT("pow") CCallConv DoubleRep
992 [promote x, promote y])
994 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
996 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
998 promote x = StMachOp MO_Flt_to_Dbl [x]
999 demote x = StMachOp MO_Dbl_to_Flt [x]
1001 --------------------
1002 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1004 = getNewRegNCG IntRep `thenNat` \ t1 ->
1005 getNewRegNCG IntRep `thenNat` \ t2 ->
1006 getNewRegNCG IntRep `thenNat` \ res_lo ->
1007 getNewRegNCG IntRep `thenNat` \ res_hi ->
1008 getRegister a1 `thenNat` \ reg1 ->
1009 getRegister a2 `thenNat` \ reg2 ->
1010 let code1 = registerCode reg1 t1
1011 code2 = registerCode reg2 t2
1012 src1 = registerName reg1 t1
1013 src2 = registerName reg2 t2
1015 MOV L (OpReg src1) (OpReg res_hi),
1016 MOV L (OpReg src2) (OpReg res_lo),
1017 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1018 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1019 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1020 MOV L (OpReg res_lo) (OpReg dst)
1021 -- dst==0 if high part == sign extended low part
1024 returnNat (Any IntRep code)
1026 --------------------
1027 shift_code :: (Imm -> Operand -> Instr)
1032 {- Case1: shift length as immediate -}
1033 -- Code is the same as the first eq. for trivialCode -- sigh.
1034 shift_code instr x y{-amount-}
1036 = getRegister x `thenNat` \ regx ->
1039 then registerCodeA regx dst `bind` \ code_x ->
1041 instr imm__2 (OpReg dst)
1042 else registerCodeF regx `bind` \ code_x ->
1043 registerNameF regx `bind` \ r_x ->
1045 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1046 instr imm__2 (OpReg dst)
1048 returnNat (Any IntRep mkcode)
1051 imm__2 = case imm of Just x -> x
1053 {- Case2: shift length is complex (non-immediate) -}
1054 -- Since ECX is always used as a spill temporary, we can't
1055 -- use it here to do non-immediate shifts. No big deal --
1056 -- they are only very rare, and we can use an equivalent
1057 -- test-and-jump sequence which doesn't use ECX.
1058 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1059 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1060 shift_code instr x y{-amount-}
1061 = getRegister x `thenNat` \ register1 ->
1062 getRegister y `thenNat` \ register2 ->
1063 getNatLabelNCG `thenNat` \ lbl_test3 ->
1064 getNatLabelNCG `thenNat` \ lbl_test2 ->
1065 getNatLabelNCG `thenNat` \ lbl_test1 ->
1066 getNatLabelNCG `thenNat` \ lbl_test0 ->
1067 getNatLabelNCG `thenNat` \ lbl_after ->
1068 getNewRegNCG IntRep `thenNat` \ tmp ->
1070 = let src_val = registerName register1 dst
1071 code_val = registerCode register1 dst
1072 src_amt = registerName register2 tmp
1073 code_amt = registerCode register2 tmp
1078 MOV L (OpReg src_amt) r_tmp `appOL`
1080 MOV L (OpReg src_val) r_dst `appOL`
1082 COMMENT (_PK_ "begin shift sequence"),
1083 MOV L (OpReg src_val) r_dst,
1084 MOV L (OpReg src_amt) r_tmp,
1086 BT L (ImmInt 4) r_tmp,
1088 instr (ImmInt 16) r_dst,
1091 BT L (ImmInt 3) r_tmp,
1093 instr (ImmInt 8) r_dst,
1096 BT L (ImmInt 2) r_tmp,
1098 instr (ImmInt 4) r_dst,
1101 BT L (ImmInt 1) r_tmp,
1103 instr (ImmInt 2) r_dst,
1106 BT L (ImmInt 0) r_tmp,
1108 instr (ImmInt 1) r_dst,
1111 COMMENT (_PK_ "end shift sequence")
1114 returnNat (Any IntRep code__2)
1116 --------------------
1117 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1119 add_code sz x (StInt y)
1120 = getRegister x `thenNat` \ register ->
1121 getNewRegNCG IntRep `thenNat` \ tmp ->
1123 code = registerCode register tmp
1124 src1 = registerName register tmp
1125 src2 = ImmInt (fromInteger y)
1128 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1131 returnNat (Any IntRep code__2)
1133 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1135 --------------------
1136 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1138 sub_code sz x (StInt y)
1139 = getRegister x `thenNat` \ register ->
1140 getNewRegNCG IntRep `thenNat` \ tmp ->
1142 code = registerCode register tmp
1143 src1 = registerName register tmp
1144 src2 = ImmInt (-(fromInteger y))
1147 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1150 returnNat (Any IntRep code__2)
1152 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1154 getRegister (StInd pk mem)
1155 | not (is64BitRep pk)
1156 = getAmode mem `thenNat` \ amode ->
1158 code = amodeCode amode
1159 src = amodeAddr amode
1160 size = primRepToSize pk
1161 code__2 dst = code `snocOL`
1162 if pk == DoubleRep || pk == FloatRep
1163 then GLD size src dst
1171 (OpAddr src) (OpReg dst)
1173 returnNat (Any pk code__2)
1175 getRegister (StInt i)
1177 src = ImmInt (fromInteger i)
1180 = unitOL (XOR L (OpReg dst) (OpReg dst))
1182 = unitOL (MOV L (OpImm src) (OpReg dst))
1184 returnNat (Any IntRep code)
1188 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1190 returnNat (Any PtrRep code)
1192 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1195 imm__2 = case imm of Just x -> x
1197 #endif {- i386_TARGET_ARCH -}
1199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1201 #if sparc_TARGET_ARCH
1203 getRegister (StFloat d)
1204 = getNatLabelNCG `thenNat` \ lbl ->
1205 getNewRegNCG PtrRep `thenNat` \ tmp ->
1206 let code dst = toOL [
1207 SEGMENT DataSegment,
1209 DATA F [ImmFloat d],
1210 SEGMENT TextSegment,
1211 SETHI (HI (ImmCLbl lbl)) tmp,
1212 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1214 returnNat (Any FloatRep code)
1216 getRegister (StDouble d)
1217 = getNatLabelNCG `thenNat` \ lbl ->
1218 getNewRegNCG PtrRep `thenNat` \ tmp ->
1219 let code dst = toOL [
1220 SEGMENT DataSegment,
1222 DATA DF [ImmDouble d],
1223 SEGMENT TextSegment,
1224 SETHI (HI (ImmCLbl lbl)) tmp,
1225 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1227 returnNat (Any DoubleRep code)
1230 getRegister (StMachOp mop [x]) -- unary PrimOps
1232 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1233 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1235 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1236 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1238 MO_Dbl_to_Flt -> coerceDbl2Flt x
1239 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1241 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1242 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1243 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1244 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1246 -- Conversions which are a nop on sparc
1247 MO_32U_to_NatS -> conversionNop IntRep x
1248 MO_NatS_to_32U -> conversionNop WordRep x
1250 MO_NatU_to_NatS -> conversionNop IntRep x
1251 MO_NatS_to_NatU -> conversionNop WordRep x
1252 MO_NatP_to_NatU -> conversionNop WordRep x
1253 MO_NatU_to_NatP -> conversionNop PtrRep x
1254 MO_NatS_to_NatP -> conversionNop PtrRep x
1255 MO_NatP_to_NatS -> conversionNop IntRep x
1257 -- sign-extending widenings
1258 MO_8U_to_NatU -> integerExtend False 24 x
1259 MO_8S_to_NatS -> integerExtend True 24 x
1260 MO_16U_to_NatU -> integerExtend False 16 x
1261 MO_16S_to_NatS -> integerExtend True 16 x
1264 let fixed_x = if is_float_op -- promote to double
1265 then StMachOp MO_Flt_to_Dbl [x]
1268 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1270 integerExtend signed nBits x
1272 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1273 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
1275 conversionNop new_rep expr
1276 = getRegister expr `thenNat` \ e_code ->
1277 returnNat (swizzleRegisterRep e_code new_rep)
1281 MO_Flt_Exp -> (True, SLIT("exp"))
1282 MO_Flt_Log -> (True, SLIT("log"))
1283 MO_Flt_Sqrt -> (True, SLIT("sqrt"))
1285 MO_Flt_Sin -> (True, SLIT("sin"))
1286 MO_Flt_Cos -> (True, SLIT("cos"))
1287 MO_Flt_Tan -> (True, SLIT("tan"))
1289 MO_Flt_Asin -> (True, SLIT("asin"))
1290 MO_Flt_Acos -> (True, SLIT("acos"))
1291 MO_Flt_Atan -> (True, SLIT("atan"))
1293 MO_Flt_Sinh -> (True, SLIT("sinh"))
1294 MO_Flt_Cosh -> (True, SLIT("cosh"))
1295 MO_Flt_Tanh -> (True, SLIT("tanh"))
1297 MO_Dbl_Exp -> (False, SLIT("exp"))
1298 MO_Dbl_Log -> (False, SLIT("log"))
1299 MO_Dbl_Sqrt -> (False, SLIT("sqrt"))
1301 MO_Dbl_Sin -> (False, SLIT("sin"))
1302 MO_Dbl_Cos -> (False, SLIT("cos"))
1303 MO_Dbl_Tan -> (False, SLIT("tan"))
1305 MO_Dbl_Asin -> (False, SLIT("asin"))
1306 MO_Dbl_Acos -> (False, SLIT("acos"))
1307 MO_Dbl_Atan -> (False, SLIT("atan"))
1309 MO_Dbl_Sinh -> (False, SLIT("sinh"))
1310 MO_Dbl_Cosh -> (False, SLIT("cosh"))
1311 MO_Dbl_Tanh -> (False, SLIT("tanh"))
1313 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1317 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1319 MO_32U_Gt -> condIntReg GTT x y
1320 MO_32U_Ge -> condIntReg GE x y
1321 MO_32U_Eq -> condIntReg EQQ x y
1322 MO_32U_Ne -> condIntReg NE x y
1323 MO_32U_Lt -> condIntReg LTT x y
1324 MO_32U_Le -> condIntReg LE x y
1326 MO_Nat_Eq -> condIntReg EQQ x y
1327 MO_Nat_Ne -> condIntReg NE x y
1329 MO_NatS_Gt -> condIntReg GTT x y
1330 MO_NatS_Ge -> condIntReg GE x y
1331 MO_NatS_Lt -> condIntReg LTT x y
1332 MO_NatS_Le -> condIntReg LE x y
1334 MO_NatU_Gt -> condIntReg GU x y
1335 MO_NatU_Ge -> condIntReg GEU x y
1336 MO_NatU_Lt -> condIntReg LU x y
1337 MO_NatU_Le -> condIntReg LEU x y
1339 MO_Flt_Gt -> condFltReg GTT x y
1340 MO_Flt_Ge -> condFltReg GE x y
1341 MO_Flt_Eq -> condFltReg EQQ x y
1342 MO_Flt_Ne -> condFltReg NE x y
1343 MO_Flt_Lt -> condFltReg LTT x y
1344 MO_Flt_Le -> condFltReg LE x y
1346 MO_Dbl_Gt -> condFltReg GTT x y
1347 MO_Dbl_Ge -> condFltReg GE x y
1348 MO_Dbl_Eq -> condFltReg EQQ x y
1349 MO_Dbl_Ne -> condFltReg NE x y
1350 MO_Dbl_Lt -> condFltReg LTT x y
1351 MO_Dbl_Le -> condFltReg LE x y
1353 MO_Nat_Add -> trivialCode (ADD False False) x y
1354 MO_Nat_Sub -> trivialCode (SUB False False) x y
1356 MO_NatS_Mul -> trivialCode (SMUL False) x y
1357 MO_NatU_Mul -> trivialCode (UMUL False) x y
1358 MO_NatS_MulMayOflo -> imulMayOflo x y
1360 -- ToDo: teach about V8+ SPARC div instructions
1361 MO_NatS_Quot -> idiv SLIT(".div") x y
1362 MO_NatS_Rem -> idiv SLIT(".rem") x y
1363 MO_NatU_Quot -> idiv SLIT(".udiv") x y
1364 MO_NatU_Rem -> idiv SLIT(".urem") x y
1366 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1367 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1368 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1369 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1371 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1372 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1373 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1374 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1376 MO_Nat_And -> trivialCode (AND False) x y
1377 MO_Nat_Or -> trivialCode (OR False) x y
1378 MO_Nat_Xor -> trivialCode (XOR False) x y
1380 MO_Nat_Shl -> trivialCode SLL x y
1381 MO_Nat_Shr -> trivialCode SRL x y
1382 MO_Nat_Sar -> trivialCode SRA x y
1384 MO_Flt_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1385 [promote x, promote y])
1386 where promote x = StMachOp MO_Flt_to_Dbl [x]
1387 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1390 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1392 idiv fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1394 --------------------
1395 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1397 = getNewRegNCG IntRep `thenNat` \ t1 ->
1398 getNewRegNCG IntRep `thenNat` \ t2 ->
1399 getNewRegNCG IntRep `thenNat` \ res_lo ->
1400 getNewRegNCG IntRep `thenNat` \ res_hi ->
1401 getRegister a1 `thenNat` \ reg1 ->
1402 getRegister a2 `thenNat` \ reg2 ->
1403 let code1 = registerCode reg1 t1
1404 code2 = registerCode reg2 t2
1405 src1 = registerName reg1 t1
1406 src2 = registerName reg2 t2
1408 SMUL False src1 (RIReg src2) res_lo,
1410 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1411 SUB False False res_lo (RIReg res_hi) dst
1414 returnNat (Any IntRep code)
1416 getRegister (StInd pk mem)
1417 = getAmode mem `thenNat` \ amode ->
1419 code = amodeCode amode
1420 src = amodeAddr amode
1421 size = primRepToSize pk
1422 code__2 dst = code `snocOL` LD size src dst
1424 returnNat (Any pk code__2)
1426 getRegister (StInt i)
1429 src = ImmInt (fromInteger i)
1430 code dst = unitOL (OR False g0 (RIImm src) dst)
1432 returnNat (Any IntRep code)
1438 SETHI (HI imm__2) dst,
1439 OR False dst (RIImm (LO imm__2)) dst]
1441 returnNat (Any PtrRep code)
1443 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1446 imm__2 = case imm of Just x -> x
1448 #endif {- sparc_TARGET_ARCH -}
1450 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1454 %************************************************************************
1456 \subsection{The @Amode@ type}
1458 %************************************************************************
1460 @Amode@s: Memory addressing modes passed up the tree.
1462 data Amode = Amode MachRegsAddr InstrBlock
1464 amodeAddr (Amode addr _) = addr
1465 amodeCode (Amode _ code) = code
1468 Now, given a tree (the argument to an StInd) that references memory,
1469 produce a suitable addressing mode.
1471 A Rule of the Game (tm) for Amodes: use of the addr bit must
1472 immediately follow use of the code part, since the code part puts
1473 values in registers which the addr then refers to. So you can't put
1474 anything in between, lest it overwrite some of those registers. If
1475 you need to do some other computation between the code part and use of
1476 the addr bit, first store the effective address from the amode in a
1477 temporary, then do the other computation, and then use the temporary:
1481 ... other computation ...
1485 getAmode :: StixExpr -> NatM Amode
1487 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1489 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1491 #if alpha_TARGET_ARCH
1493 getAmode (StPrim IntSubOp [x, StInt i])
1494 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1495 getRegister x `thenNat` \ register ->
1497 code = registerCode register tmp
1498 reg = registerName register tmp
1499 off = ImmInt (-(fromInteger i))
1501 returnNat (Amode (AddrRegImm reg off) code)
1503 getAmode (StPrim IntAddOp [x, StInt i])
1504 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1505 getRegister x `thenNat` \ register ->
1507 code = registerCode register tmp
1508 reg = registerName register tmp
1509 off = ImmInt (fromInteger i)
1511 returnNat (Amode (AddrRegImm reg off) code)
1515 = returnNat (Amode (AddrImm imm__2) id)
1518 imm__2 = case imm of Just x -> x
1521 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1522 getRegister other `thenNat` \ register ->
1524 code = registerCode register tmp
1525 reg = registerName register tmp
1527 returnNat (Amode (AddrReg reg) code)
1529 #endif {- alpha_TARGET_ARCH -}
1531 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1533 #if i386_TARGET_ARCH
1535 -- This is all just ridiculous, since it carefully undoes
1536 -- what mangleIndexTree has just done.
1537 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1538 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1539 getRegister x `thenNat` \ register ->
1541 code = registerCode register tmp
1542 reg = registerName register tmp
1543 off = ImmInt (-(fromInteger i))
1545 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1547 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1549 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1552 imm__2 = case imm of Just x -> x
1554 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1555 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1556 getRegister x `thenNat` \ register ->
1558 code = registerCode register tmp
1559 reg = registerName register tmp
1560 off = ImmInt (fromInteger i)
1562 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1564 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1565 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1566 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1567 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1568 getRegister x `thenNat` \ register1 ->
1569 getRegister y `thenNat` \ register2 ->
1571 code1 = registerCode register1 tmp1
1572 reg1 = registerName register1 tmp1
1573 code2 = registerCode register2 tmp2
1574 reg2 = registerName register2 tmp2
1575 code__2 = code1 `appOL` code2
1576 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1578 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1583 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1586 imm__2 = case imm of Just x -> x
1589 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1590 getRegister other `thenNat` \ register ->
1592 code = registerCode register tmp
1593 reg = registerName register tmp
1595 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1597 #endif {- i386_TARGET_ARCH -}
1599 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1601 #if sparc_TARGET_ARCH
1603 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1605 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1606 getRegister x `thenNat` \ register ->
1608 code = registerCode register tmp
1609 reg = registerName register tmp
1610 off = ImmInt (-(fromInteger i))
1612 returnNat (Amode (AddrRegImm reg off) code)
1615 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1617 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1618 getRegister x `thenNat` \ register ->
1620 code = registerCode register tmp
1621 reg = registerName register tmp
1622 off = ImmInt (fromInteger i)
1624 returnNat (Amode (AddrRegImm reg off) code)
1626 getAmode (StMachOp MO_Nat_Add [x, y])
1627 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1628 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1629 getRegister x `thenNat` \ register1 ->
1630 getRegister y `thenNat` \ register2 ->
1632 code1 = registerCode register1 tmp1
1633 reg1 = registerName register1 tmp1
1634 code2 = registerCode register2 tmp2
1635 reg2 = registerName register2 tmp2
1636 code__2 = code1 `appOL` code2
1638 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1642 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1644 code = unitOL (SETHI (HI imm__2) tmp)
1646 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1649 imm__2 = case imm of Just x -> x
1652 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1653 getRegister other `thenNat` \ register ->
1655 code = registerCode register tmp
1656 reg = registerName register tmp
1659 returnNat (Amode (AddrRegImm reg off) code)
1661 #endif {- sparc_TARGET_ARCH -}
1663 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1666 %************************************************************************
1668 \subsection{The @CondCode@ type}
1670 %************************************************************************
1672 Condition codes passed up the tree.
1674 data CondCode = CondCode Bool Cond InstrBlock
1676 condName (CondCode _ cond _) = cond
1677 condFloat (CondCode is_float _ _) = is_float
1678 condCode (CondCode _ _ code) = code
1681 Set up a condition code for a conditional branch.
1684 getCondCode :: StixExpr -> NatM CondCode
1686 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1688 #if alpha_TARGET_ARCH
1689 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1690 #endif {- alpha_TARGET_ARCH -}
1692 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1694 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1695 -- yes, they really do seem to want exactly the same!
1697 getCondCode (StMachOp mop [x, y])
1699 MO_32U_Gt -> condIntCode GTT x y
1700 MO_32U_Ge -> condIntCode GE x y
1701 MO_32U_Eq -> condIntCode EQQ x y
1702 MO_32U_Ne -> condIntCode NE x y
1703 MO_32U_Lt -> condIntCode LTT x y
1704 MO_32U_Le -> condIntCode LE x y
1706 MO_Nat_Eq -> condIntCode EQQ x y
1707 MO_Nat_Ne -> condIntCode NE x y
1709 MO_NatS_Gt -> condIntCode GTT x y
1710 MO_NatS_Ge -> condIntCode GE x y
1711 MO_NatS_Lt -> condIntCode LTT x y
1712 MO_NatS_Le -> condIntCode LE x y
1714 MO_NatU_Gt -> condIntCode GU x y
1715 MO_NatU_Ge -> condIntCode GEU x y
1716 MO_NatU_Lt -> condIntCode LU x y
1717 MO_NatU_Le -> condIntCode LEU x y
1719 MO_Flt_Gt -> condFltCode GTT x y
1720 MO_Flt_Ge -> condFltCode GE x y
1721 MO_Flt_Eq -> condFltCode EQQ x y
1722 MO_Flt_Ne -> condFltCode NE x y
1723 MO_Flt_Lt -> condFltCode LTT x y
1724 MO_Flt_Le -> condFltCode LE x y
1726 MO_Dbl_Gt -> condFltCode GTT x y
1727 MO_Dbl_Ge -> condFltCode GE x y
1728 MO_Dbl_Eq -> condFltCode EQQ x y
1729 MO_Dbl_Ne -> condFltCode NE x y
1730 MO_Dbl_Lt -> condFltCode LTT x y
1731 MO_Dbl_Le -> condFltCode LE x y
1733 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1735 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1737 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1739 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1744 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1745 passed back up the tree.
1748 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1750 #if alpha_TARGET_ARCH
1751 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1752 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1753 #endif {- alpha_TARGET_ARCH -}
1755 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1756 #if i386_TARGET_ARCH
1758 -- memory vs immediate
1759 condIntCode cond (StInd pk x) y
1760 | Just i <- maybeImm y
1761 = getAmode x `thenNat` \ amode ->
1763 code1 = amodeCode amode
1764 x__2 = amodeAddr amode
1765 sz = primRepToSize pk
1766 code__2 = code1 `snocOL`
1767 CMP sz (OpImm i) (OpAddr x__2)
1769 returnNat (CondCode False cond code__2)
1772 condIntCode cond x (StInt 0)
1773 = getRegister x `thenNat` \ register1 ->
1774 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1776 code1 = registerCode register1 tmp1
1777 src1 = registerName register1 tmp1
1778 code__2 = code1 `snocOL`
1779 TEST L (OpReg src1) (OpReg src1)
1781 returnNat (CondCode False cond code__2)
1783 -- anything vs immediate
1784 condIntCode cond x y
1785 | Just i <- maybeImm y
1786 = getRegister x `thenNat` \ register1 ->
1787 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1789 code1 = registerCode register1 tmp1
1790 src1 = registerName register1 tmp1
1791 code__2 = code1 `snocOL`
1792 CMP L (OpImm i) (OpReg src1)
1794 returnNat (CondCode False cond code__2)
1796 -- memory vs anything
1797 condIntCode cond (StInd pk x) y
1798 = getAmode x `thenNat` \ amode_x ->
1799 getRegister y `thenNat` \ reg_y ->
1800 getNewRegNCG IntRep `thenNat` \ tmp ->
1802 c_x = amodeCode amode_x
1803 am_x = amodeAddr amode_x
1804 c_y = registerCode reg_y tmp
1805 r_y = registerName reg_y tmp
1806 sz = primRepToSize pk
1808 -- optimisation: if there's no code for x, just an amode,
1809 -- use whatever reg y winds up in. Assumes that c_y doesn't
1810 -- clobber any regs in the amode am_x, which I'm not sure is
1811 -- justified. The otherwise clause makes the same assumption.
1812 code__2 | isNilOL c_x
1814 CMP sz (OpReg r_y) (OpAddr am_x)
1818 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1820 CMP sz (OpReg tmp) (OpAddr am_x)
1822 returnNat (CondCode False cond code__2)
1824 -- anything vs memory
1826 condIntCode cond y (StInd pk x)
1827 = getAmode x `thenNat` \ amode_x ->
1828 getRegister y `thenNat` \ reg_y ->
1829 getNewRegNCG IntRep `thenNat` \ tmp ->
1831 c_x = amodeCode amode_x
1832 am_x = amodeAddr amode_x
1833 c_y = registerCode reg_y tmp
1834 r_y = registerName reg_y tmp
1835 sz = primRepToSize pk
1836 -- same optimisation and nagging doubts as previous clause
1837 code__2 | isNilOL c_x
1839 CMP sz (OpAddr am_x) (OpReg r_y)
1843 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1845 CMP sz (OpAddr am_x) (OpReg tmp)
1847 returnNat (CondCode False cond code__2)
1849 -- anything vs anything
1850 condIntCode cond x y
1851 = getRegister x `thenNat` \ register1 ->
1852 getRegister y `thenNat` \ register2 ->
1853 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1854 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1856 code1 = registerCode register1 tmp1
1857 src1 = registerName register1 tmp1
1858 code2 = registerCode register2 tmp2
1859 src2 = registerName register2 tmp2
1860 code__2 = code1 `snocOL`
1861 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1863 CMP L (OpReg src2) (OpReg tmp1)
1865 returnNat (CondCode False cond code__2)
1868 condFltCode cond x y
1869 = getRegister x `thenNat` \ register1 ->
1870 getRegister y `thenNat` \ register2 ->
1871 getNewRegNCG (registerRep register1)
1873 getNewRegNCG (registerRep register2)
1875 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1877 pk1 = registerRep register1
1878 code1 = registerCode register1 tmp1
1879 src1 = registerName register1 tmp1
1881 code2 = registerCode register2 tmp2
1882 src2 = registerName register2 tmp2
1884 code__2 | isAny register1
1885 = code1 `appOL` -- result in tmp1
1887 GCMP (primRepToSize pk1) tmp1 src2
1891 GMOV src1 tmp1 `appOL`
1893 GCMP (primRepToSize pk1) tmp1 src2
1895 {- On the 486, the flags set by FP compare are the unsigned ones!
1896 (This looks like a HACK to me. WDP 96/03)
1898 fix_FP_cond :: Cond -> Cond
1900 fix_FP_cond GE = GEU
1901 fix_FP_cond GTT = GU
1902 fix_FP_cond LTT = LU
1903 fix_FP_cond LE = LEU
1904 fix_FP_cond any = any
1906 returnNat (CondCode True (fix_FP_cond cond) code__2)
1908 #endif {- i386_TARGET_ARCH -}
1910 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1912 #if sparc_TARGET_ARCH
1914 condIntCode cond x (StInt y)
1916 = getRegister x `thenNat` \ register ->
1917 getNewRegNCG IntRep `thenNat` \ tmp ->
1919 code = registerCode register tmp
1920 src1 = registerName register tmp
1921 src2 = ImmInt (fromInteger y)
1922 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1924 returnNat (CondCode False cond code__2)
1926 condIntCode cond x y
1927 = getRegister x `thenNat` \ register1 ->
1928 getRegister y `thenNat` \ register2 ->
1929 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1930 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1932 code1 = registerCode register1 tmp1
1933 src1 = registerName register1 tmp1
1934 code2 = registerCode register2 tmp2
1935 src2 = registerName register2 tmp2
1936 code__2 = code1 `appOL` code2 `snocOL`
1937 SUB False True src1 (RIReg src2) g0
1939 returnNat (CondCode False cond code__2)
1942 condFltCode cond x y
1943 = getRegister x `thenNat` \ register1 ->
1944 getRegister y `thenNat` \ register2 ->
1945 getNewRegNCG (registerRep register1)
1947 getNewRegNCG (registerRep register2)
1949 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1951 promote x = FxTOy F DF x tmp
1953 pk1 = registerRep register1
1954 code1 = registerCode register1 tmp1
1955 src1 = registerName register1 tmp1
1957 pk2 = registerRep register2
1958 code2 = registerCode register2 tmp2
1959 src2 = registerName register2 tmp2
1963 code1 `appOL` code2 `snocOL`
1964 FCMP True (primRepToSize pk1) src1 src2
1965 else if pk1 == FloatRep then
1966 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1967 FCMP True DF tmp src2
1969 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1970 FCMP True DF src1 tmp
1972 returnNat (CondCode True cond code__2)
1974 #endif {- sparc_TARGET_ARCH -}
1976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1979 %************************************************************************
1981 \subsection{Generating assignments}
1983 %************************************************************************
1985 Assignments are really at the heart of the whole code generation
1986 business. Almost all top-level nodes of any real importance are
1987 assignments, which correspond to loads, stores, or register transfers.
1988 If we're really lucky, some of the register transfers will go away,
1989 because we can use the destination register to complete the code
1990 generation for the right hand side. This only fails when the right
1991 hand side is forced into a fixed register (e.g. the result of a call).
1994 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1995 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
1997 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1998 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2000 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2002 #if alpha_TARGET_ARCH
2004 assignIntCode pk (StInd _ dst) src
2005 = getNewRegNCG IntRep `thenNat` \ tmp ->
2006 getAmode dst `thenNat` \ amode ->
2007 getRegister src `thenNat` \ register ->
2009 code1 = amodeCode amode []
2010 dst__2 = amodeAddr amode
2011 code2 = registerCode register tmp []
2012 src__2 = registerName register tmp
2013 sz = primRepToSize pk
2014 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2018 assignIntCode pk dst src
2019 = getRegister dst `thenNat` \ register1 ->
2020 getRegister src `thenNat` \ register2 ->
2022 dst__2 = registerName register1 zeroh
2023 code = registerCode register2 dst__2
2024 src__2 = registerName register2 dst__2
2025 code__2 = if isFixed register2
2026 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2031 #endif {- alpha_TARGET_ARCH -}
2033 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2035 #if i386_TARGET_ARCH
2037 -- non-FP assignment to memory
2038 assignMem_IntCode pk addr src
2039 = getAmode addr `thenNat` \ amode ->
2040 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2041 getNewRegNCG PtrRep `thenNat` \ tmp ->
2043 -- In general, if the address computation for dst may require
2044 -- some insns preceding the addressing mode itself. So there's
2045 -- no guarantee that the code for dst and the code for src won't
2046 -- write the same register. This means either the address or
2047 -- the value needs to be copied into a temporary. We detect the
2048 -- common case where the amode has no code, and elide the copy.
2049 codea = amodeCode amode
2050 dst__a = amodeAddr amode
2052 code | isNilOL codea
2054 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2057 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2059 MOV (primRepToSize pk) opsrc
2060 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2066 -> NatM (InstrBlock,Operand) -- code, operator
2069 | Just x <- maybeImm op
2070 = returnNat (nilOL, OpImm x)
2073 = getRegister op `thenNat` \ register ->
2074 getNewRegNCG (registerRep register)
2076 let code = registerCode register tmp
2077 reg = registerName register tmp
2079 returnNat (code, OpReg reg)
2081 -- Assign; dst is a reg, rhs is mem
2082 assignReg_IntCode pk reg (StInd pks src)
2083 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2084 getAmode src `thenNat` \ amode ->
2085 getRegisterReg reg `thenNat` \ reg_dst ->
2087 c_addr = amodeCode amode
2088 am_addr = amodeAddr amode
2089 r_dst = registerName reg_dst tmp
2090 szs = primRepToSize pks
2099 code = c_addr `snocOL`
2100 opc (OpAddr am_addr) (OpReg r_dst)
2104 -- dst is a reg, but src could be anything
2105 assignReg_IntCode pk reg src
2106 = getRegisterReg reg `thenNat` \ registerd ->
2107 getRegister src `thenNat` \ registers ->
2108 getNewRegNCG IntRep `thenNat` \ tmp ->
2110 r_dst = registerName registerd tmp
2111 r_src = registerName registers r_dst
2112 c_src = registerCode registers r_dst
2114 code = c_src `snocOL`
2115 MOV L (OpReg r_src) (OpReg r_dst)
2119 #endif {- i386_TARGET_ARCH -}
2121 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2123 #if sparc_TARGET_ARCH
2125 assignMem_IntCode pk addr src
2126 = getNewRegNCG IntRep `thenNat` \ tmp ->
2127 getAmode addr `thenNat` \ amode ->
2128 getRegister src `thenNat` \ register ->
2130 code1 = amodeCode amode
2131 dst__2 = amodeAddr amode
2132 code2 = registerCode register tmp
2133 src__2 = registerName register tmp
2134 sz = primRepToSize pk
2135 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2139 assignReg_IntCode pk reg src
2140 = getRegister src `thenNat` \ register2 ->
2141 getRegisterReg reg `thenNat` \ register1 ->
2143 dst__2 = registerName register1 g0
2144 code = registerCode register2 dst__2
2145 src__2 = registerName register2 dst__2
2146 code__2 = if isFixed register2
2147 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2152 #endif {- sparc_TARGET_ARCH -}
2154 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2157 % --------------------------------
2158 Floating-point assignments:
2159 % --------------------------------
2162 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2163 #if alpha_TARGET_ARCH
2165 assignFltCode pk (StInd _ dst) src
2166 = getNewRegNCG pk `thenNat` \ tmp ->
2167 getAmode dst `thenNat` \ amode ->
2168 getRegister src `thenNat` \ register ->
2170 code1 = amodeCode amode []
2171 dst__2 = amodeAddr amode
2172 code2 = registerCode register tmp []
2173 src__2 = registerName register tmp
2174 sz = primRepToSize pk
2175 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2179 assignFltCode pk dst src
2180 = getRegister dst `thenNat` \ register1 ->
2181 getRegister src `thenNat` \ register2 ->
2183 dst__2 = registerName register1 zeroh
2184 code = registerCode register2 dst__2
2185 src__2 = registerName register2 dst__2
2186 code__2 = if isFixed register2
2187 then code . mkSeqInstr (FMOV src__2 dst__2)
2192 #endif {- alpha_TARGET_ARCH -}
2194 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2196 #if i386_TARGET_ARCH
2198 -- Floating point assignment to memory
2199 assignMem_FltCode pk addr src
2200 = getRegister src `thenNat` \ reg_src ->
2201 getRegister addr `thenNat` \ reg_addr ->
2202 getNewRegNCG pk `thenNat` \ tmp_src ->
2203 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2204 let r_src = registerName reg_src tmp_src
2205 c_src = registerCode reg_src tmp_src
2206 r_addr = registerName reg_addr tmp_addr
2207 c_addr = registerCode reg_addr tmp_addr
2208 sz = primRepToSize pk
2210 code = c_src `appOL`
2211 -- no need to preserve r_src across the addr computation,
2212 -- since r_src must be a float reg
2213 -- whilst r_addr is an int reg
2216 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2220 -- Floating point assignment to a register/temporary
2221 assignReg_FltCode pk reg src
2222 = getRegisterReg reg `thenNat` \ reg_dst ->
2223 getRegister src `thenNat` \ reg_src ->
2224 getNewRegNCG pk `thenNat` \ tmp ->
2226 r_dst = registerName reg_dst tmp
2227 r_src = registerName reg_src r_dst
2228 c_src = registerCode reg_src r_dst
2230 code = if isFixed reg_src
2231 then c_src `snocOL` GMOV r_src r_dst
2237 #endif {- i386_TARGET_ARCH -}
2239 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2241 #if sparc_TARGET_ARCH
2243 -- Floating point assignment to memory
2244 assignMem_FltCode pk addr src
2245 = getNewRegNCG pk `thenNat` \ tmp1 ->
2246 getAmode addr `thenNat` \ amode ->
2247 getRegister src `thenNat` \ register ->
2249 sz = primRepToSize pk
2250 dst__2 = amodeAddr amode
2252 code1 = amodeCode amode
2253 code2 = registerCode register tmp1
2255 src__2 = registerName register tmp1
2256 pk__2 = registerRep register
2257 sz__2 = primRepToSize pk__2
2259 code__2 = code1 `appOL` code2 `appOL`
2261 then unitOL (ST sz src__2 dst__2)
2262 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2266 -- Floating point assignment to a register/temporary
2267 -- Why is this so bizarrely ugly?
2268 assignReg_FltCode pk reg src
2269 = getRegisterReg reg `thenNat` \ register1 ->
2270 getRegister src `thenNat` \ register2 ->
2272 pk__2 = registerRep register2
2273 sz__2 = primRepToSize pk__2
2275 getNewRegNCG pk__2 `thenNat` \ tmp ->
2277 sz = primRepToSize pk
2278 dst__2 = registerName register1 g0 -- must be Fixed
2279 reg__2 = if pk /= pk__2 then tmp else dst__2
2280 code = registerCode register2 reg__2
2281 src__2 = registerName register2 reg__2
2284 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2285 else if isFixed register2 then
2286 code `snocOL` FMOV sz src__2 dst__2
2292 #endif {- sparc_TARGET_ARCH -}
2294 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2297 %************************************************************************
2299 \subsection{Generating an unconditional branch}
2301 %************************************************************************
2303 We accept two types of targets: an immediate CLabel or a tree that
2304 gets evaluated into a register. Any CLabels which are AsmTemporaries
2305 are assumed to be in the local block of code, close enough for a
2306 branch instruction. Other CLabels are assumed to be far away.
2308 (If applicable) Do not fill the delay slots here; you will confuse the
2312 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2314 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2316 #if alpha_TARGET_ARCH
2318 genJump (StCLbl lbl)
2319 | isAsmTemp lbl = returnInstr (BR target)
2320 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2322 target = ImmCLbl lbl
2325 = getRegister tree `thenNat` \ register ->
2326 getNewRegNCG PtrRep `thenNat` \ tmp ->
2328 dst = registerName register pv
2329 code = registerCode register pv
2330 target = registerName register pv
2332 if isFixed register then
2333 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2335 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2337 #endif {- alpha_TARGET_ARCH -}
2339 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2341 #if i386_TARGET_ARCH
2343 genJump dsts (StInd pk mem)
2344 = getAmode mem `thenNat` \ amode ->
2346 code = amodeCode amode
2347 target = amodeAddr amode
2349 returnNat (code `snocOL` JMP dsts (OpAddr target))
2353 = returnNat (unitOL (JMP dsts (OpImm target)))
2356 = getRegister tree `thenNat` \ register ->
2357 getNewRegNCG PtrRep `thenNat` \ tmp ->
2359 code = registerCode register tmp
2360 target = registerName register tmp
2362 returnNat (code `snocOL` JMP dsts (OpReg target))
2365 target = case imm of Just x -> x
2367 #endif {- i386_TARGET_ARCH -}
2369 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2371 #if sparc_TARGET_ARCH
2373 genJump dsts (StCLbl lbl)
2374 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2375 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2376 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2378 target = ImmCLbl lbl
2381 = getRegister tree `thenNat` \ register ->
2382 getNewRegNCG PtrRep `thenNat` \ tmp ->
2384 code = registerCode register tmp
2385 target = registerName register tmp
2387 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2389 #endif {- sparc_TARGET_ARCH -}
2391 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2394 %************************************************************************
2396 \subsection{Conditional jumps}
2398 %************************************************************************
2400 Conditional jumps are always to local labels, so we can use branch
2401 instructions. We peek at the arguments to decide what kind of
2404 ALPHA: For comparisons with 0, we're laughing, because we can just do
2405 the desired conditional branch.
2407 I386: First, we have to ensure that the condition
2408 codes are set according to the supplied comparison operation.
2410 SPARC: First, we have to ensure that the condition codes are set
2411 according to the supplied comparison operation. We generate slightly
2412 different code for floating point comparisons, because a floating
2413 point operation cannot directly precede a @BF@. We assume the worst
2414 and fill that slot with a @NOP@.
2416 SPARC: Do not fill the delay slots here; you will confuse the register
2421 :: CLabel -- the branch target
2422 -> StixExpr -- the condition on which to branch
2425 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2427 #if alpha_TARGET_ARCH
2429 genCondJump lbl (StPrim op [x, StInt 0])
2430 = getRegister x `thenNat` \ register ->
2431 getNewRegNCG (registerRep register)
2434 code = registerCode register tmp
2435 value = registerName register tmp
2436 pk = registerRep register
2437 target = ImmCLbl lbl
2439 returnSeq code [BI (cmpOp op) value target]
2441 cmpOp CharGtOp = GTT
2443 cmpOp CharEqOp = EQQ
2445 cmpOp CharLtOp = LTT
2454 cmpOp WordGeOp = ALWAYS
2455 cmpOp WordEqOp = EQQ
2457 cmpOp WordLtOp = NEVER
2458 cmpOp WordLeOp = EQQ
2460 cmpOp AddrGeOp = ALWAYS
2461 cmpOp AddrEqOp = EQQ
2463 cmpOp AddrLtOp = NEVER
2464 cmpOp AddrLeOp = EQQ
2466 genCondJump lbl (StPrim op [x, StDouble 0.0])
2467 = getRegister x `thenNat` \ register ->
2468 getNewRegNCG (registerRep register)
2471 code = registerCode register tmp
2472 value = registerName register tmp
2473 pk = registerRep register
2474 target = ImmCLbl lbl
2476 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2478 cmpOp FloatGtOp = GTT
2479 cmpOp FloatGeOp = GE
2480 cmpOp FloatEqOp = EQQ
2481 cmpOp FloatNeOp = NE
2482 cmpOp FloatLtOp = LTT
2483 cmpOp FloatLeOp = LE
2484 cmpOp DoubleGtOp = GTT
2485 cmpOp DoubleGeOp = GE
2486 cmpOp DoubleEqOp = EQQ
2487 cmpOp DoubleNeOp = NE
2488 cmpOp DoubleLtOp = LTT
2489 cmpOp DoubleLeOp = LE
2491 genCondJump lbl (StPrim op [x, y])
2493 = trivialFCode pr instr x y `thenNat` \ register ->
2494 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2496 code = registerCode register tmp
2497 result = registerName register tmp
2498 target = ImmCLbl lbl
2500 returnNat (code . mkSeqInstr (BF cond result target))
2502 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2504 fltCmpOp op = case op of
2518 (instr, cond) = case op of
2519 FloatGtOp -> (FCMP TF LE, EQQ)
2520 FloatGeOp -> (FCMP TF LTT, EQQ)
2521 FloatEqOp -> (FCMP TF EQQ, NE)
2522 FloatNeOp -> (FCMP TF EQQ, EQQ)
2523 FloatLtOp -> (FCMP TF LTT, NE)
2524 FloatLeOp -> (FCMP TF LE, NE)
2525 DoubleGtOp -> (FCMP TF LE, EQQ)
2526 DoubleGeOp -> (FCMP TF LTT, EQQ)
2527 DoubleEqOp -> (FCMP TF EQQ, NE)
2528 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2529 DoubleLtOp -> (FCMP TF LTT, NE)
2530 DoubleLeOp -> (FCMP TF LE, NE)
2532 genCondJump lbl (StPrim op [x, y])
2533 = trivialCode instr x y `thenNat` \ register ->
2534 getNewRegNCG IntRep `thenNat` \ tmp ->
2536 code = registerCode register tmp
2537 result = registerName register tmp
2538 target = ImmCLbl lbl
2540 returnNat (code . mkSeqInstr (BI cond result target))
2542 (instr, cond) = case op of
2543 CharGtOp -> (CMP LE, EQQ)
2544 CharGeOp -> (CMP LTT, EQQ)
2545 CharEqOp -> (CMP EQQ, NE)
2546 CharNeOp -> (CMP EQQ, EQQ)
2547 CharLtOp -> (CMP LTT, NE)
2548 CharLeOp -> (CMP LE, NE)
2549 IntGtOp -> (CMP LE, EQQ)
2550 IntGeOp -> (CMP LTT, EQQ)
2551 IntEqOp -> (CMP EQQ, NE)
2552 IntNeOp -> (CMP EQQ, EQQ)
2553 IntLtOp -> (CMP LTT, NE)
2554 IntLeOp -> (CMP LE, NE)
2555 WordGtOp -> (CMP ULE, EQQ)
2556 WordGeOp -> (CMP ULT, EQQ)
2557 WordEqOp -> (CMP EQQ, NE)
2558 WordNeOp -> (CMP EQQ, EQQ)
2559 WordLtOp -> (CMP ULT, NE)
2560 WordLeOp -> (CMP ULE, NE)
2561 AddrGtOp -> (CMP ULE, EQQ)
2562 AddrGeOp -> (CMP ULT, EQQ)
2563 AddrEqOp -> (CMP EQQ, NE)
2564 AddrNeOp -> (CMP EQQ, EQQ)
2565 AddrLtOp -> (CMP ULT, NE)
2566 AddrLeOp -> (CMP ULE, NE)
2568 #endif {- alpha_TARGET_ARCH -}
2570 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2572 #if i386_TARGET_ARCH
2574 genCondJump lbl bool
2575 = getCondCode bool `thenNat` \ condition ->
2577 code = condCode condition
2578 cond = condName condition
2580 returnNat (code `snocOL` JXX cond lbl)
2582 #endif {- i386_TARGET_ARCH -}
2584 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2586 #if sparc_TARGET_ARCH
2588 genCondJump lbl bool
2589 = getCondCode bool `thenNat` \ condition ->
2591 code = condCode condition
2592 cond = condName condition
2593 target = ImmCLbl lbl
2598 if condFloat condition
2599 then [NOP, BF cond False target, NOP]
2600 else [BI cond False target, NOP]
2604 #endif {- sparc_TARGET_ARCH -}
2606 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2609 %************************************************************************
2611 \subsection{Generating C calls}
2613 %************************************************************************
2615 Now the biggest nightmare---calls. Most of the nastiness is buried in
2616 @get_arg@, which moves the arguments to the correct registers/stack
2617 locations. Apart from that, the code is easy.
2619 (If applicable) Do not fill the delay slots here; you will confuse the
2624 :: FAST_STRING -- function to call
2626 -> PrimRep -- type of the result
2627 -> [StixExpr] -- arguments (of mixed type)
2630 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2632 #if alpha_TARGET_ARCH
2634 genCCall fn cconv kind args
2635 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2636 `thenNat` \ ((unused,_), argCode) ->
2638 nRegs = length allArgRegs - length unused
2639 code = asmSeqThen (map ($ []) argCode)
2642 LDA pv (AddrImm (ImmLab (ptext fn))),
2643 JSR ra (AddrReg pv) nRegs,
2644 LDGP gp (AddrReg ra)]
2646 ------------------------
2647 {- Try to get a value into a specific register (or registers) for
2648 a call. The first 6 arguments go into the appropriate
2649 argument register (separate registers for integer and floating
2650 point arguments, but used in lock-step), and the remaining
2651 arguments are dumped to the stack, beginning at 0(sp). Our
2652 first argument is a pair of the list of remaining argument
2653 registers to be assigned for this call and the next stack
2654 offset to use for overflowing arguments. This way,
2655 @get_Arg@ can be applied to all of a call's arguments using
2659 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2660 -> StixTree -- Current argument
2661 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2663 -- We have to use up all of our argument registers first...
2665 get_arg ((iDst,fDst):dsts, offset) arg
2666 = getRegister arg `thenNat` \ register ->
2668 reg = if isFloatingRep pk then fDst else iDst
2669 code = registerCode register reg
2670 src = registerName register reg
2671 pk = registerRep register
2674 if isFloatingRep pk then
2675 ((dsts, offset), if isFixed register then
2676 code . mkSeqInstr (FMOV src fDst)
2679 ((dsts, offset), if isFixed register then
2680 code . mkSeqInstr (OR src (RIReg src) iDst)
2683 -- Once we have run out of argument registers, we move to the
2686 get_arg ([], offset) arg
2687 = getRegister arg `thenNat` \ register ->
2688 getNewRegNCG (registerRep register)
2691 code = registerCode register tmp
2692 src = registerName register tmp
2693 pk = registerRep register
2694 sz = primRepToSize pk
2696 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2698 #endif {- alpha_TARGET_ARCH -}
2700 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2702 #if i386_TARGET_ARCH
2704 genCCall fn cconv ret_rep [StInt i]
2705 | fn == SLIT ("PerformGC_wrapper")
2707 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2708 CALL (ImmLit (ptext (if underscorePrefix
2709 then (SLIT ("_PerformGC_wrapper"))
2710 else (SLIT ("PerformGC_wrapper")))))
2716 genCCall fn cconv ret_rep args
2718 (reverse args) `thenNat` \ sizes_n_codes ->
2719 getDeltaNat `thenNat` \ delta ->
2720 let (sizes, codes) = unzip sizes_n_codes
2721 tot_arg_size = sum sizes
2722 code2 = concatOL codes
2724 [CALL (fn__2 tot_arg_size)]
2726 -- Deallocate parameters after call for ccall;
2727 -- but not for stdcall (callee does it)
2728 (if cconv == StdCallConv then [] else
2729 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2732 [DELTA (delta + tot_arg_size)]
2735 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2736 returnNat (code2 `appOL` call)
2739 -- function names that begin with '.' are assumed to be special
2740 -- internally generated names like '.mul,' which don't get an
2741 -- underscore prefix
2742 -- ToDo:needed (WDP 96/03) ???
2746 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2747 | otherwise -- General case
2748 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2750 stdcallsize tot_arg_size
2751 | cconv == StdCallConv = '@':show tot_arg_size
2759 push_arg :: StixExpr{-current argument-}
2760 -> NatM (Int, InstrBlock) -- argsz, code
2763 | is64BitRep arg_rep
2764 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2765 getDeltaNat `thenNat` \ delta ->
2766 setDeltaNat (delta - 8) `thenNat` \ _ ->
2767 let r_lo = VirtualRegI vr_lo
2768 r_hi = getHiVRegFromLo r_lo
2771 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2772 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2775 = get_op arg `thenNat` \ (code, reg, sz) ->
2776 getDeltaNat `thenNat` \ delta ->
2777 arg_size sz `bind` \ size ->
2778 setDeltaNat (delta-size) `thenNat` \ _ ->
2779 if (case sz of DF -> True; F -> True; _ -> False)
2780 then returnNat (size,
2782 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2784 GST sz reg (AddrBaseIndex (Just esp)
2788 else returnNat (size,
2790 PUSH L (OpReg reg) `snocOL`
2794 arg_rep = repOfStixExpr arg
2799 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2802 = getRegister op `thenNat` \ register ->
2803 getNewRegNCG (registerRep register)
2806 code = registerCode register tmp
2807 reg = registerName register tmp
2808 pk = registerRep register
2809 sz = primRepToSize pk
2811 returnNat (code, reg, sz)
2813 #endif {- i386_TARGET_ARCH -}
2815 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2817 #if sparc_TARGET_ARCH
2819 The SPARC calling convention is an absolute
2820 nightmare. The first 6x32 bits of arguments are mapped into
2821 %o0 through %o5, and the remaining arguments are dumped to the
2822 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2824 If we have to put args on the stack, move %o6==%sp down by
2825 the number of words to go on the stack, to ensure there's enough space.
2827 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2828 16 words above the stack pointer is a word for the address of
2829 a structure return value. I use this as a temporary location
2830 for moving values from float to int regs. Certainly it isn't
2831 safe to put anything in the 16 words starting at %sp, since
2832 this area can get trashed at any time due to window overflows
2833 caused by signal handlers.
2835 A final complication (if the above isn't enough) is that
2836 we can't blithely calculate the arguments one by one into
2837 %o0 .. %o5. Consider the following nested calls:
2841 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2842 the inner call will itself use %o0, which trashes the value put there
2843 in preparation for the outer call. Upshot: we need to calculate the
2844 args into temporary regs, and move those to arg regs or onto the
2845 stack only immediately prior to the call proper. Sigh.
2848 genCCall fn cconv kind args
2849 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2850 let (argcodes, vregss) = unzip argcode_and_vregs
2851 argcode = concatOL argcodes
2852 vregs = concat vregss
2853 n_argRegs = length allArgRegs
2854 n_argRegs_used = min (length vregs) n_argRegs
2855 (move_sp_down, move_sp_up)
2856 = let nn = length vregs - n_argRegs
2857 + 1 -- (for the road)
2860 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2862 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2864 = unitOL (CALL fn__2 n_argRegs_used False)
2866 returnNat (argcode `appOL`
2867 move_sp_down `appOL`
2868 transfer_code `appOL`
2873 -- function names that begin with '.' are assumed to be special
2874 -- internally generated names like '.mul,' which don't get an
2875 -- underscore prefix
2876 -- ToDo:needed (WDP 96/03) ???
2877 fn__2 = case (_HEAD_ fn) of
2878 '.' -> ImmLit (ptext fn)
2879 _ -> ImmLab False (ptext fn)
2881 -- move args from the integer vregs into which they have been
2882 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2883 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2885 move_final [] _ offset -- all args done
2888 move_final (v:vs) [] offset -- out of aregs; move to stack
2889 = ST W v (spRel offset)
2890 : move_final vs [] (offset+1)
2892 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2893 = OR False g0 (RIReg v) a
2894 : move_final vs az offset
2896 -- generate code to calculate an argument, and move it into one
2897 -- or two integer vregs.
2898 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2899 arg_to_int_vregs arg
2900 | is64BitRep (repOfStixExpr arg)
2901 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2902 let r_lo = VirtualRegI vr_lo
2903 r_hi = getHiVRegFromLo r_lo
2904 in returnNat (code, [r_hi, r_lo])
2906 = getRegister arg `thenNat` \ register ->
2907 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2908 let code = registerCode register tmp
2909 src = registerName register tmp
2910 pk = registerRep register
2912 -- the value is in src. Get it into 1 or 2 int vregs.
2915 getNewRegNCG WordRep `thenNat` \ v1 ->
2916 getNewRegNCG WordRep `thenNat` \ v2 ->
2919 FMOV DF src f0 `snocOL`
2920 ST F f0 (spRel 16) `snocOL`
2921 LD W (spRel 16) v1 `snocOL`
2922 ST F (fPair f0) (spRel 16) `snocOL`
2928 getNewRegNCG WordRep `thenNat` \ v1 ->
2931 ST F src (spRel 16) `snocOL`
2937 getNewRegNCG WordRep `thenNat` \ v1 ->
2939 code `snocOL` OR False g0 (RIReg src) v1
2943 #endif {- sparc_TARGET_ARCH -}
2945 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2948 %************************************************************************
2950 \subsection{Support bits}
2952 %************************************************************************
2954 %************************************************************************
2956 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2958 %************************************************************************
2960 Turn those condition codes into integers now (when they appear on
2961 the right hand side of an assignment).
2963 (If applicable) Do not fill the delay slots here; you will confuse the
2967 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2969 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2971 #if alpha_TARGET_ARCH
2972 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2973 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2974 #endif {- alpha_TARGET_ARCH -}
2976 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2978 #if i386_TARGET_ARCH
2981 = condIntCode cond x y `thenNat` \ condition ->
2982 getNewRegNCG IntRep `thenNat` \ tmp ->
2984 code = condCode condition
2985 cond = condName condition
2986 code__2 dst = code `appOL` toOL [
2987 SETCC cond (OpReg tmp),
2988 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2989 MOV L (OpReg tmp) (OpReg dst)]
2991 returnNat (Any IntRep code__2)
2994 = getNatLabelNCG `thenNat` \ lbl1 ->
2995 getNatLabelNCG `thenNat` \ lbl2 ->
2996 condFltCode cond x y `thenNat` \ condition ->
2998 code = condCode condition
2999 cond = condName condition
3000 code__2 dst = code `appOL` toOL [
3002 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3005 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3008 returnNat (Any IntRep code__2)
3010 #endif {- i386_TARGET_ARCH -}
3012 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3014 #if sparc_TARGET_ARCH
3016 condIntReg EQQ x (StInt 0)
3017 = getRegister x `thenNat` \ register ->
3018 getNewRegNCG IntRep `thenNat` \ tmp ->
3020 code = registerCode register tmp
3021 src = registerName register tmp
3022 code__2 dst = code `appOL` toOL [
3023 SUB False True g0 (RIReg src) g0,
3024 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3026 returnNat (Any IntRep code__2)
3029 = getRegister x `thenNat` \ register1 ->
3030 getRegister y `thenNat` \ register2 ->
3031 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3032 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3034 code1 = registerCode register1 tmp1
3035 src1 = registerName register1 tmp1
3036 code2 = registerCode register2 tmp2
3037 src2 = registerName register2 tmp2
3038 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3039 XOR False src1 (RIReg src2) dst,
3040 SUB False True g0 (RIReg dst) g0,
3041 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3043 returnNat (Any IntRep code__2)
3045 condIntReg NE x (StInt 0)
3046 = getRegister x `thenNat` \ register ->
3047 getNewRegNCG IntRep `thenNat` \ tmp ->
3049 code = registerCode register tmp
3050 src = registerName register tmp
3051 code__2 dst = code `appOL` toOL [
3052 SUB False True g0 (RIReg src) g0,
3053 ADD True False g0 (RIImm (ImmInt 0)) dst]
3055 returnNat (Any IntRep code__2)
3058 = getRegister x `thenNat` \ register1 ->
3059 getRegister y `thenNat` \ register2 ->
3060 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3061 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3063 code1 = registerCode register1 tmp1
3064 src1 = registerName register1 tmp1
3065 code2 = registerCode register2 tmp2
3066 src2 = registerName register2 tmp2
3067 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3068 XOR False src1 (RIReg src2) dst,
3069 SUB False True g0 (RIReg dst) g0,
3070 ADD True False g0 (RIImm (ImmInt 0)) dst]
3072 returnNat (Any IntRep code__2)
3075 = getNatLabelNCG `thenNat` \ lbl1 ->
3076 getNatLabelNCG `thenNat` \ lbl2 ->
3077 condIntCode cond x y `thenNat` \ condition ->
3079 code = condCode condition
3080 cond = condName condition
3081 code__2 dst = code `appOL` toOL [
3082 BI cond False (ImmCLbl lbl1), NOP,
3083 OR False g0 (RIImm (ImmInt 0)) dst,
3084 BI ALWAYS False (ImmCLbl lbl2), NOP,
3086 OR False g0 (RIImm (ImmInt 1)) dst,
3089 returnNat (Any IntRep code__2)
3092 = getNatLabelNCG `thenNat` \ lbl1 ->
3093 getNatLabelNCG `thenNat` \ lbl2 ->
3094 condFltCode cond x y `thenNat` \ condition ->
3096 code = condCode condition
3097 cond = condName condition
3098 code__2 dst = code `appOL` toOL [
3100 BF cond False (ImmCLbl lbl1), NOP,
3101 OR False g0 (RIImm (ImmInt 0)) dst,
3102 BI ALWAYS False (ImmCLbl lbl2), NOP,
3104 OR False g0 (RIImm (ImmInt 1)) dst,
3107 returnNat (Any IntRep code__2)
3109 #endif {- sparc_TARGET_ARCH -}
3111 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3114 %************************************************************************
3116 \subsubsection{@trivial*Code@: deal with trivial instructions}
3118 %************************************************************************
3120 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3121 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3122 for constants on the right hand side, because that's where the generic
3123 optimizer will have put them.
3125 Similarly, for unary instructions, we don't have to worry about
3126 matching an StInt as the argument, because genericOpt will already
3127 have handled the constant-folding.
3131 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3132 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3133 -> Maybe (Operand -> Operand -> Instr)
3134 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3136 -> StixExpr -> StixExpr -- the two arguments
3141 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3142 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3143 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3145 -> StixExpr -> StixExpr -- the two arguments
3149 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3150 ,IF_ARCH_i386 ((Operand -> Instr)
3151 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3153 -> StixExpr -- the one argument
3158 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3159 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3160 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3162 -> StixExpr -- the one argument
3165 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3167 #if alpha_TARGET_ARCH
3169 trivialCode instr x (StInt y)
3171 = getRegister x `thenNat` \ register ->
3172 getNewRegNCG IntRep `thenNat` \ tmp ->
3174 code = registerCode register tmp
3175 src1 = registerName register tmp
3176 src2 = ImmInt (fromInteger y)
3177 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3179 returnNat (Any IntRep code__2)
3181 trivialCode instr x y
3182 = getRegister x `thenNat` \ register1 ->
3183 getRegister y `thenNat` \ register2 ->
3184 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3185 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3187 code1 = registerCode register1 tmp1 []
3188 src1 = registerName register1 tmp1
3189 code2 = registerCode register2 tmp2 []
3190 src2 = registerName register2 tmp2
3191 code__2 dst = asmSeqThen [code1, code2] .
3192 mkSeqInstr (instr src1 (RIReg src2) dst)
3194 returnNat (Any IntRep code__2)
3197 trivialUCode instr x
3198 = getRegister x `thenNat` \ register ->
3199 getNewRegNCG IntRep `thenNat` \ tmp ->
3201 code = registerCode register tmp
3202 src = registerName register tmp
3203 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3205 returnNat (Any IntRep code__2)
3208 trivialFCode _ instr x y
3209 = getRegister x `thenNat` \ register1 ->
3210 getRegister y `thenNat` \ register2 ->
3211 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3212 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3214 code1 = registerCode register1 tmp1
3215 src1 = registerName register1 tmp1
3217 code2 = registerCode register2 tmp2
3218 src2 = registerName register2 tmp2
3220 code__2 dst = asmSeqThen [code1 [], code2 []] .
3221 mkSeqInstr (instr src1 src2 dst)
3223 returnNat (Any DoubleRep code__2)
3225 trivialUFCode _ instr x
3226 = getRegister x `thenNat` \ register ->
3227 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3229 code = registerCode register tmp
3230 src = registerName register tmp
3231 code__2 dst = code . mkSeqInstr (instr src dst)
3233 returnNat (Any DoubleRep code__2)
3235 #endif {- alpha_TARGET_ARCH -}
3237 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3239 #if i386_TARGET_ARCH
3241 The Rules of the Game are:
3243 * You cannot assume anything about the destination register dst;
3244 it may be anything, including a fixed reg.
3246 * You may compute an operand into a fixed reg, but you may not
3247 subsequently change the contents of that fixed reg. If you
3248 want to do so, first copy the value either to a temporary
3249 or into dst. You are free to modify dst even if it happens
3250 to be a fixed reg -- that's not your problem.
3252 * You cannot assume that a fixed reg will stay live over an
3253 arbitrary computation. The same applies to the dst reg.
3255 * Temporary regs obtained from getNewRegNCG are distinct from
3256 each other and from all other regs, and stay live over
3257 arbitrary computations.
3261 trivialCode instr maybe_revinstr a b
3264 = getRegister a `thenNat` \ rega ->
3267 then registerCode rega dst `bind` \ code_a ->
3269 instr (OpImm imm_b) (OpReg dst)
3270 else registerCodeF rega `bind` \ code_a ->
3271 registerNameF rega `bind` \ r_a ->
3273 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3274 instr (OpImm imm_b) (OpReg dst)
3276 returnNat (Any IntRep mkcode)
3279 = getRegister b `thenNat` \ regb ->
3280 getNewRegNCG IntRep `thenNat` \ tmp ->
3281 let revinstr_avail = maybeToBool maybe_revinstr
3282 revinstr = case maybe_revinstr of Just ri -> ri
3286 then registerCode regb dst `bind` \ code_b ->
3288 revinstr (OpImm imm_a) (OpReg dst)
3289 else registerCodeF regb `bind` \ code_b ->
3290 registerNameF regb `bind` \ r_b ->
3292 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3293 revinstr (OpImm imm_a) (OpReg dst)
3297 then registerCode regb tmp `bind` \ code_b ->
3299 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3300 instr (OpReg tmp) (OpReg dst)
3301 else registerCodeF regb `bind` \ code_b ->
3302 registerNameF regb `bind` \ r_b ->
3304 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3305 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3306 instr (OpReg tmp) (OpReg dst)
3308 returnNat (Any IntRep mkcode)
3311 = getRegister a `thenNat` \ rega ->
3312 getRegister b `thenNat` \ regb ->
3313 getNewRegNCG IntRep `thenNat` \ tmp ->
3315 = case (isAny rega, isAny regb) of
3317 -> registerCode regb tmp `bind` \ code_b ->
3318 registerCode rega dst `bind` \ code_a ->
3321 instr (OpReg tmp) (OpReg dst)
3323 -> registerCode rega tmp `bind` \ code_a ->
3324 registerCodeF regb `bind` \ code_b ->
3325 registerNameF regb `bind` \ r_b ->
3328 instr (OpReg r_b) (OpReg tmp) `snocOL`
3329 MOV L (OpReg tmp) (OpReg dst)
3331 -> registerCode regb tmp `bind` \ code_b ->
3332 registerCodeF rega `bind` \ code_a ->
3333 registerNameF rega `bind` \ r_a ->
3336 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3337 instr (OpReg tmp) (OpReg dst)
3339 -> registerCodeF rega `bind` \ code_a ->
3340 registerNameF rega `bind` \ r_a ->
3341 registerCodeF regb `bind` \ code_b ->
3342 registerNameF regb `bind` \ r_b ->
3344 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3346 instr (OpReg r_b) (OpReg tmp) `snocOL`
3347 MOV L (OpReg tmp) (OpReg dst)
3349 returnNat (Any IntRep mkcode)
3352 maybe_imm_a = maybeImm a
3353 is_imm_a = maybeToBool maybe_imm_a
3354 imm_a = case maybe_imm_a of Just imm -> imm
3356 maybe_imm_b = maybeImm b
3357 is_imm_b = maybeToBool maybe_imm_b
3358 imm_b = case maybe_imm_b of Just imm -> imm
3362 trivialUCode instr x
3363 = getRegister x `thenNat` \ register ->
3365 code__2 dst = let code = registerCode register dst
3366 src = registerName register dst
3368 if isFixed register && dst /= src
3369 then toOL [MOV L (OpReg src) (OpReg dst),
3371 else unitOL (instr (OpReg src))
3373 returnNat (Any IntRep code__2)
3376 trivialFCode pk instr x y
3377 = getRegister x `thenNat` \ register1 ->
3378 getRegister y `thenNat` \ register2 ->
3379 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3380 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3382 code1 = registerCode register1 tmp1
3383 src1 = registerName register1 tmp1
3385 code2 = registerCode register2 tmp2
3386 src2 = registerName register2 tmp2
3389 -- treat the common case specially: both operands in
3391 | isAny register1 && isAny register2
3394 instr (primRepToSize pk) src1 src2 dst
3396 -- be paranoid (and inefficient)
3398 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3400 instr (primRepToSize pk) tmp1 src2 dst
3402 returnNat (Any pk code__2)
3406 trivialUFCode pk instr x
3407 = getRegister x `thenNat` \ register ->
3408 getNewRegNCG pk `thenNat` \ tmp ->
3410 code = registerCode register tmp
3411 src = registerName register tmp
3412 code__2 dst = code `snocOL` instr src dst
3414 returnNat (Any pk code__2)
3416 #endif {- i386_TARGET_ARCH -}
3418 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3420 #if sparc_TARGET_ARCH
3422 trivialCode instr x (StInt y)
3424 = getRegister x `thenNat` \ register ->
3425 getNewRegNCG IntRep `thenNat` \ tmp ->
3427 code = registerCode register tmp
3428 src1 = registerName register tmp
3429 src2 = ImmInt (fromInteger y)
3430 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3432 returnNat (Any IntRep code__2)
3434 trivialCode instr x y
3435 = getRegister x `thenNat` \ register1 ->
3436 getRegister y `thenNat` \ register2 ->
3437 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3438 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3440 code1 = registerCode register1 tmp1
3441 src1 = registerName register1 tmp1
3442 code2 = registerCode register2 tmp2
3443 src2 = registerName register2 tmp2
3444 code__2 dst = code1 `appOL` code2 `snocOL`
3445 instr src1 (RIReg src2) dst
3447 returnNat (Any IntRep code__2)
3450 trivialFCode pk instr x y
3451 = getRegister x `thenNat` \ register1 ->
3452 getRegister y `thenNat` \ register2 ->
3453 getNewRegNCG (registerRep register1)
3455 getNewRegNCG (registerRep register2)
3457 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3459 promote x = FxTOy F DF x tmp
3461 pk1 = registerRep register1
3462 code1 = registerCode register1 tmp1
3463 src1 = registerName register1 tmp1
3465 pk2 = registerRep register2
3466 code2 = registerCode register2 tmp2
3467 src2 = registerName register2 tmp2
3471 code1 `appOL` code2 `snocOL`
3472 instr (primRepToSize pk) src1 src2 dst
3473 else if pk1 == FloatRep then
3474 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3475 instr DF tmp src2 dst
3477 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3478 instr DF src1 tmp dst
3480 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3483 trivialUCode instr x
3484 = getRegister x `thenNat` \ register ->
3485 getNewRegNCG IntRep `thenNat` \ tmp ->
3487 code = registerCode register tmp
3488 src = registerName register tmp
3489 code__2 dst = code `snocOL` instr (RIReg src) dst
3491 returnNat (Any IntRep code__2)
3494 trivialUFCode pk instr x
3495 = getRegister x `thenNat` \ register ->
3496 getNewRegNCG pk `thenNat` \ tmp ->
3498 code = registerCode register tmp
3499 src = registerName register tmp
3500 code__2 dst = code `snocOL` instr src dst
3502 returnNat (Any pk code__2)
3504 #endif {- sparc_TARGET_ARCH -}
3506 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3509 %************************************************************************
3511 \subsubsection{Coercing to/from integer/floating-point...}
3513 %************************************************************************
3515 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3516 conversions. We have to store temporaries in memory to move
3517 between the integer and the floating point register sets.
3519 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3520 pretend, on sparc at least, that double and float regs are seperate
3521 kinds, so the value has to be computed into one kind before being
3522 explicitly "converted" to live in the other kind.
3525 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3526 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3528 coerceDbl2Flt :: StixExpr -> NatM Register
3529 coerceFlt2Dbl :: StixExpr -> NatM Register
3533 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3535 #if alpha_TARGET_ARCH
3538 = getRegister x `thenNat` \ register ->
3539 getNewRegNCG IntRep `thenNat` \ reg ->
3541 code = registerCode register reg
3542 src = registerName register reg
3544 code__2 dst = code . mkSeqInstrs [
3546 LD TF dst (spRel 0),
3549 returnNat (Any DoubleRep code__2)
3553 = getRegister x `thenNat` \ register ->
3554 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3556 code = registerCode register tmp
3557 src = registerName register tmp
3559 code__2 dst = code . mkSeqInstrs [
3561 ST TF tmp (spRel 0),
3564 returnNat (Any IntRep code__2)
3566 #endif {- alpha_TARGET_ARCH -}
3568 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3570 #if i386_TARGET_ARCH
3573 = getRegister x `thenNat` \ register ->
3574 getNewRegNCG IntRep `thenNat` \ reg ->
3576 code = registerCode register reg
3577 src = registerName register reg
3578 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3579 code__2 dst = code `snocOL` opc src dst
3581 returnNat (Any pk code__2)
3584 coerceFP2Int fprep x
3585 = getRegister x `thenNat` \ register ->
3586 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3588 code = registerCode register tmp
3589 src = registerName register tmp
3590 pk = registerRep register
3592 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3593 code__2 dst = code `snocOL` opc src dst
3595 returnNat (Any IntRep code__2)
3598 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3599 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3601 #endif {- i386_TARGET_ARCH -}
3603 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3605 #if sparc_TARGET_ARCH
3608 = getRegister x `thenNat` \ register ->
3609 getNewRegNCG IntRep `thenNat` \ reg ->
3611 code = registerCode register reg
3612 src = registerName register reg
3614 code__2 dst = code `appOL` toOL [
3615 ST W src (spRel (-2)),
3616 LD W (spRel (-2)) dst,
3617 FxTOy W (primRepToSize pk) dst dst]
3619 returnNat (Any pk code__2)
3622 coerceFP2Int fprep x
3623 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3624 getRegister x `thenNat` \ register ->
3625 getNewRegNCG fprep `thenNat` \ reg ->
3626 getNewRegNCG FloatRep `thenNat` \ tmp ->
3628 code = registerCode register reg
3629 src = registerName register reg
3630 code__2 dst = code `appOL` toOL [
3631 FxTOy (primRepToSize fprep) W src tmp,
3632 ST W tmp (spRel (-2)),
3633 LD W (spRel (-2)) dst]
3635 returnNat (Any IntRep code__2)
3639 = getRegister x `thenNat` \ register ->
3640 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3641 let code = registerCode register tmp
3642 src = registerName register tmp
3644 returnNat (Any FloatRep
3645 (\dst -> code `snocOL` FxTOy DF F src dst))
3649 = getRegister x `thenNat` \ register ->
3650 getNewRegNCG FloatRep `thenNat` \ tmp ->
3651 let code = registerCode register tmp
3652 src = registerName register tmp
3654 returnNat (Any DoubleRep
3655 (\dst -> code `snocOL` FxTOy F DF src dst))
3657 #endif {- sparc_TARGET_ARCH -}
3659 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -