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 )
52 import Outputable ( assertPanic )
57 @InstrBlock@s are the insn sequences generated by the insn selectors.
58 They are really trees of insns to facilitate fast appending, where a
59 left-to-right traversal (pre-order?) yields the insns in the correct
63 type InstrBlock = OrdList Instr
67 isLeft (Left _) = True
68 isLeft (Right _) = False
73 Code extractor for an entire stix tree---stix statement level.
76 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
78 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
79 returnNat (concatOL instrss)
82 stmtToInstrs :: StixStmt -> NatM InstrBlock
83 stmtToInstrs stmt = case stmt of
84 StComment s -> returnNat (unitOL (COMMENT s))
85 StSegment seg -> returnNat (unitOL (SEGMENT seg))
87 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
89 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
92 StLabel lab -> returnNat (unitOL (LABEL lab))
94 StJump dsts arg -> genJump dsts (derefDLL arg)
95 StCondJump lab arg -> genCondJump lab (derefDLL arg)
97 -- A call returning void, ie one done for its side-effects. Note
98 -- that this is the only StVoidable we handle.
99 StVoidable (StCall fn cconv VoidRep args)
100 -> genCCall fn cconv VoidRep (map derefDLL args)
102 StAssignMem pk addr src
103 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
104 | ncg_target_is_32bit
105 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
106 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
107 StAssignReg pk reg src
108 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
109 | ncg_target_is_32bit
110 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
111 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
114 -- When falling through on the Alpha, we still have to load pv
115 -- with the address of the next routine, so that it can load gp.
116 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
120 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
121 returnNat (DATA (primRepToSize kind) imms
122 `consOL` concatOL codes)
124 getData :: StixExpr -> NatM (InstrBlock, Imm)
125 getData (StInt i) = returnNat (nilOL, ImmInteger i)
126 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
127 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
128 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
129 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
130 -- the linker can handle simple arithmetic...
131 getData (StIndex rep (StCLbl lbl) (StInt off)) =
133 ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
135 -- Top-level lifted-out string. The segment will already have been set
136 -- (see Stix.liftStrings).
138 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
141 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
144 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
145 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
146 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
148 derefDLL :: StixExpr -> StixExpr
150 | opt_Static -- short out the entire deal if not doing DLLs
157 StCLbl lbl -> if labelDynamic lbl
158 then StInd PtrRep (StCLbl lbl)
160 -- all the rest are boring
161 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
162 StMachOp mop args -> StMachOp mop (map qq args)
163 StInd pk addr -> StInd pk (qq addr)
164 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
165 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
171 _ -> pprPanic "derefDLL: unhandled case"
175 %************************************************************************
177 \subsection{General things for putting together code sequences}
179 %************************************************************************
182 mangleIndexTree :: StixExpr -> StixExpr
184 mangleIndexTree (StIndex pk base (StInt i))
185 = StMachOp MO_Nat_Add [base, off]
187 off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
189 mangleIndexTree (StIndex pk base off)
190 = StMachOp MO_Nat_Add [
193 in if s == 0 then off
194 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
197 shift :: PrimRep -> Int
198 shift rep = case getPrimRepArrayElemSize rep of
203 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
204 (Outputable.int other)
208 maybeImm :: StixExpr -> Maybe Imm
212 maybeImm (StIndex rep (StCLbl l) (StInt off))
213 = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
215 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
216 = Just (ImmInt (fromInteger i))
218 = Just (ImmInteger i)
223 %************************************************************************
225 \subsection{The @Register64@ type}
227 %************************************************************************
229 Simple support for generating 64-bit code (ie, 64 bit values and 64
230 bit assignments) on 32-bit platforms. Unlike the main code generator
231 we merely shoot for generating working code as simply as possible, and
232 pay little attention to code quality. Specifically, there is no
233 attempt to deal cleverly with the fixed-vs-floating register
234 distinction; all values are generated into (pairs of) floating
235 registers, even if this would mean some redundant reg-reg moves as a
236 result. Only one of the VRegUniques is returned, since it will be
237 of the VRegUniqueLo form, and the upper-half VReg can be determined
238 by applying getHiVRegFromLo to it.
242 data ChildCode64 -- a.k.a "Register64"
245 VRegUnique -- unique for the lower 32-bit temporary
246 -- which contains the result; use getHiVRegFromLo to find
247 -- the other VRegUnique.
248 -- Rules of this simplified insn selection game are
249 -- therefore that the returned VRegUnique may be modified
251 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
252 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
253 iselExpr64 :: StixExpr -> NatM ChildCode64
255 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
259 assignMem_I64Code addrTree valueTree
260 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
261 getRegister addrTree `thenNat` \ register_addr ->
262 getNewRegNCG IntRep `thenNat` \ t_addr ->
263 let rlo = VirtualRegI vrlo
264 rhi = getHiVRegFromLo rlo
265 code_addr = registerCode register_addr t_addr
266 reg_addr = registerName register_addr t_addr
267 -- Little-endian store
268 mov_lo = MOV L (OpReg rlo)
269 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
270 mov_hi = MOV L (OpReg rhi)
271 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
273 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
275 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
276 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
278 r_dst_lo = mkVReg u_dst IntRep
279 r_src_lo = VirtualRegI vr_src_lo
280 r_dst_hi = getHiVRegFromLo r_dst_lo
281 r_src_hi = getHiVRegFromLo r_src_lo
282 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
283 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
286 vcode `snocOL` mov_lo `snocOL` mov_hi
289 assignReg_I64Code lvalue valueTree
290 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
295 iselExpr64 (StInd pk addrTree)
297 = getRegister addrTree `thenNat` \ register_addr ->
298 getNewRegNCG IntRep `thenNat` \ t_addr ->
299 getNewRegNCG IntRep `thenNat` \ rlo ->
300 let rhi = getHiVRegFromLo rlo
301 code_addr = registerCode register_addr t_addr
302 reg_addr = registerName register_addr t_addr
303 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
305 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
309 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
313 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
315 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
316 let r_dst_hi = getHiVRegFromLo r_dst_lo
317 r_src_lo = mkVReg vu IntRep
318 r_src_hi = getHiVRegFromLo r_src_lo
319 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
320 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
323 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
326 iselExpr64 (StCall fn cconv kind args)
328 = genCCall fn cconv kind args `thenNat` \ call ->
329 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
330 let r_dst_hi = getHiVRegFromLo r_dst_lo
331 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
332 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
335 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
336 (getVRegUnique r_dst_lo)
340 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
342 #endif {- i386_TARGET_ARCH -}
344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
346 #if sparc_TARGET_ARCH
348 assignMem_I64Code addrTree valueTree
349 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
350 getRegister addrTree `thenNat` \ register_addr ->
351 getNewRegNCG IntRep `thenNat` \ t_addr ->
352 let rlo = VirtualRegI vrlo
353 rhi = getHiVRegFromLo rlo
354 code_addr = registerCode register_addr t_addr
355 reg_addr = registerName register_addr t_addr
357 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
358 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
360 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
363 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
364 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
366 r_dst_lo = mkVReg u_dst IntRep
367 r_src_lo = VirtualRegI vr_src_lo
368 r_dst_hi = getHiVRegFromLo r_dst_lo
369 r_src_hi = getHiVRegFromLo r_src_lo
370 mov_lo = mkMOV r_src_lo r_dst_lo
371 mov_hi = mkMOV r_src_hi r_dst_hi
372 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
375 vcode `snocOL` mov_hi `snocOL` mov_lo
377 assignReg_I64Code lvalue valueTree
378 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
382 -- Don't delete this -- it's very handy for debugging.
384 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
385 -- = panic "iselExpr64(???)"
387 iselExpr64 (StInd pk addrTree)
389 = getRegister addrTree `thenNat` \ register_addr ->
390 getNewRegNCG IntRep `thenNat` \ t_addr ->
391 getNewRegNCG IntRep `thenNat` \ rlo ->
392 let rhi = getHiVRegFromLo rlo
393 code_addr = registerCode register_addr t_addr
394 reg_addr = registerName register_addr t_addr
395 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
396 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
399 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
403 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
405 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
406 let r_dst_hi = getHiVRegFromLo r_dst_lo
407 r_src_lo = mkVReg vu IntRep
408 r_src_hi = getHiVRegFromLo r_src_lo
409 mov_lo = mkMOV r_src_lo r_dst_lo
410 mov_hi = mkMOV r_src_hi r_dst_hi
411 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
414 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
417 iselExpr64 (StCall fn cconv kind args)
419 = genCCall fn cconv kind args `thenNat` \ call ->
420 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
421 let r_dst_hi = getHiVRegFromLo r_dst_lo
422 mov_lo = mkMOV o0 r_dst_lo
423 mov_hi = mkMOV o1 r_dst_hi
424 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
427 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
428 (getVRegUnique r_dst_lo)
432 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
434 #endif {- sparc_TARGET_ARCH -}
436 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
440 %************************************************************************
442 \subsection{The @Register@ type}
444 %************************************************************************
446 @Register@s passed up the tree. If the stix code forces the register
447 to live in a pre-decided machine register, it comes out as @Fixed@;
448 otherwise, it comes out as @Any@, and the parent can decide which
449 register to put it in.
453 = Fixed PrimRep Reg InstrBlock
454 | Any PrimRep (Reg -> InstrBlock)
456 registerCode :: Register -> Reg -> InstrBlock
457 registerCode (Fixed _ _ code) reg = code
458 registerCode (Any _ code) reg = code reg
460 registerCodeF (Fixed _ _ code) = code
461 registerCodeF (Any _ _) = panic "registerCodeF"
463 registerCodeA (Any _ code) = code
464 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
466 registerName :: Register -> Reg -> Reg
467 registerName (Fixed _ reg _) _ = reg
468 registerName (Any _ _) reg = reg
470 registerNameF (Fixed _ reg _) = reg
471 registerNameF (Any _ _) = panic "registerNameF"
473 registerRep :: Register -> PrimRep
474 registerRep (Fixed pk _ _) = pk
475 registerRep (Any pk _) = pk
477 swizzleRegisterRep :: Register -> PrimRep -> Register
478 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
479 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
481 {-# INLINE registerCode #-}
482 {-# INLINE registerCodeF #-}
483 {-# INLINE registerName #-}
484 {-# INLINE registerNameF #-}
485 {-# INLINE registerRep #-}
486 {-# INLINE isFixed #-}
489 isFixed, isAny :: Register -> Bool
490 isFixed (Fixed _ _ _) = True
491 isFixed (Any _ _) = False
493 isAny = not . isFixed
496 Generate code to get a subtree into a @Register@:
499 getRegisterReg :: StixReg -> NatM Register
500 getRegister :: StixExpr -> NatM Register
503 getRegisterReg (StixMagicId mid)
504 = case get_MagicId_reg_or_addr mid of
506 -> let pk = magicIdPrimRep mid
507 in returnNat (Fixed pk (RealReg rrno) nilOL)
509 -- By this stage, the only MagicIds remaining should be the
510 -- ones which map to a real machine register on this platform. Hence ...
511 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
513 getRegisterReg (StixTemp (StixVReg u pk))
514 = returnNat (Fixed pk (mkVReg u pk) nilOL)
518 -- Don't delete this -- it's very handy for debugging.
520 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
521 -- = panic "getRegister(???)"
523 getRegister (StReg reg)
526 getRegister tree@(StIndex _ _ _)
527 = getRegister (mangleIndexTree tree)
529 getRegister (StCall fn cconv kind args)
530 | not (ncg_target_is_32bit && is64BitRep kind)
531 = genCCall fn cconv kind args `thenNat` \ call ->
532 returnNat (Fixed kind reg call)
534 reg = if isFloatingRep kind
535 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
536 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
538 getRegister (StString s)
539 = getNatLabelNCG `thenNat` \ lbl ->
541 imm_lbl = ImmCLbl lbl
544 SEGMENT RoDataSegment,
546 ASCII True (_UNPK_ s),
548 #if alpha_TARGET_ARCH
549 LDA dst (AddrImm imm_lbl)
552 MOV L (OpImm imm_lbl) (OpReg dst)
554 #if sparc_TARGET_ARCH
555 SETHI (HI imm_lbl) dst,
556 OR False dst (RIImm (LO imm_lbl)) dst
560 returnNat (Any PtrRep code)
562 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
563 -- end of machine-"independent" bit; here we go on the rest...
565 #if alpha_TARGET_ARCH
567 getRegister (StDouble d)
568 = getNatLabelNCG `thenNat` \ lbl ->
569 getNewRegNCG PtrRep `thenNat` \ tmp ->
570 let code dst = mkSeqInstrs [
573 DATA TF [ImmLab (rational d)],
575 LDA tmp (AddrImm (ImmCLbl lbl)),
576 LD TF dst (AddrReg tmp)]
578 returnNat (Any DoubleRep code)
580 getRegister (StPrim primop [x]) -- unary PrimOps
582 IntNegOp -> trivialUCode (NEG Q False) x
584 NotOp -> trivialUCode NOT x
586 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
587 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
589 OrdOp -> coerceIntCode IntRep x
592 Float2IntOp -> coerceFP2Int x
593 Int2FloatOp -> coerceInt2FP pr x
594 Double2IntOp -> coerceFP2Int x
595 Int2DoubleOp -> coerceInt2FP pr x
597 Double2FloatOp -> coerceFltCode x
598 Float2DoubleOp -> coerceFltCode x
600 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
602 fn = case other_op of
603 FloatExpOp -> SLIT("exp")
604 FloatLogOp -> SLIT("log")
605 FloatSqrtOp -> SLIT("sqrt")
606 FloatSinOp -> SLIT("sin")
607 FloatCosOp -> SLIT("cos")
608 FloatTanOp -> SLIT("tan")
609 FloatAsinOp -> SLIT("asin")
610 FloatAcosOp -> SLIT("acos")
611 FloatAtanOp -> SLIT("atan")
612 FloatSinhOp -> SLIT("sinh")
613 FloatCoshOp -> SLIT("cosh")
614 FloatTanhOp -> SLIT("tanh")
615 DoubleExpOp -> SLIT("exp")
616 DoubleLogOp -> SLIT("log")
617 DoubleSqrtOp -> SLIT("sqrt")
618 DoubleSinOp -> SLIT("sin")
619 DoubleCosOp -> SLIT("cos")
620 DoubleTanOp -> SLIT("tan")
621 DoubleAsinOp -> SLIT("asin")
622 DoubleAcosOp -> SLIT("acos")
623 DoubleAtanOp -> SLIT("atan")
624 DoubleSinhOp -> SLIT("sinh")
625 DoubleCoshOp -> SLIT("cosh")
626 DoubleTanhOp -> SLIT("tanh")
628 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
630 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
632 CharGtOp -> trivialCode (CMP LTT) y x
633 CharGeOp -> trivialCode (CMP LE) y x
634 CharEqOp -> trivialCode (CMP EQQ) x y
635 CharNeOp -> int_NE_code x y
636 CharLtOp -> trivialCode (CMP LTT) x y
637 CharLeOp -> trivialCode (CMP LE) x y
639 IntGtOp -> trivialCode (CMP LTT) y x
640 IntGeOp -> trivialCode (CMP LE) y x
641 IntEqOp -> trivialCode (CMP EQQ) x y
642 IntNeOp -> int_NE_code x y
643 IntLtOp -> trivialCode (CMP LTT) x y
644 IntLeOp -> trivialCode (CMP LE) x y
646 WordGtOp -> trivialCode (CMP ULT) y x
647 WordGeOp -> trivialCode (CMP ULE) x y
648 WordEqOp -> trivialCode (CMP EQQ) x y
649 WordNeOp -> int_NE_code x y
650 WordLtOp -> trivialCode (CMP ULT) x y
651 WordLeOp -> trivialCode (CMP ULE) x y
653 AddrGtOp -> trivialCode (CMP ULT) y x
654 AddrGeOp -> trivialCode (CMP ULE) y x
655 AddrEqOp -> trivialCode (CMP EQQ) x y
656 AddrNeOp -> int_NE_code x y
657 AddrLtOp -> trivialCode (CMP ULT) x y
658 AddrLeOp -> trivialCode (CMP ULE) x y
660 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
661 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
662 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
663 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
664 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
665 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
667 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
668 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
669 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
670 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
671 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
672 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
674 IntAddOp -> trivialCode (ADD Q False) x y
675 IntSubOp -> trivialCode (SUB Q False) x y
676 IntMulOp -> trivialCode (MUL Q False) x y
677 IntQuotOp -> trivialCode (DIV Q False) x y
678 IntRemOp -> trivialCode (REM Q False) x y
680 WordAddOp -> trivialCode (ADD Q False) x y
681 WordSubOp -> trivialCode (SUB Q False) x y
682 WordMulOp -> trivialCode (MUL Q False) x y
683 WordQuotOp -> trivialCode (DIV Q True) x y
684 WordRemOp -> trivialCode (REM Q True) x y
686 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
687 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
688 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
689 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
691 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
692 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
693 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
694 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
696 AddrAddOp -> trivialCode (ADD Q False) x y
697 AddrSubOp -> trivialCode (SUB Q False) x y
698 AddrRemOp -> trivialCode (REM Q True) x y
700 AndOp -> trivialCode AND x y
701 OrOp -> trivialCode OR x y
702 XorOp -> trivialCode XOR x y
703 SllOp -> trivialCode SLL x y
704 SrlOp -> trivialCode SRL x y
706 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
707 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
708 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
710 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
711 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
713 {- ------------------------------------------------------------
714 Some bizarre special code for getting condition codes into
715 registers. Integer non-equality is a test for equality
716 followed by an XOR with 1. (Integer comparisons always set
717 the result register to 0 or 1.) Floating point comparisons of
718 any kind leave the result in a floating point register, so we
719 need to wrangle an integer register out of things.
721 int_NE_code :: StixTree -> StixTree -> NatM Register
724 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
725 getNewRegNCG IntRep `thenNat` \ tmp ->
727 code = registerCode register tmp
728 src = registerName register tmp
729 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
731 returnNat (Any IntRep code__2)
733 {- ------------------------------------------------------------
734 Comments for int_NE_code also apply to cmpF_code
737 :: (Reg -> Reg -> Reg -> Instr)
739 -> StixTree -> StixTree
742 cmpF_code instr cond x y
743 = trivialFCode pr instr x y `thenNat` \ register ->
744 getNewRegNCG DoubleRep `thenNat` \ tmp ->
745 getNatLabelNCG `thenNat` \ lbl ->
747 code = registerCode register tmp
748 result = registerName register tmp
750 code__2 dst = code . mkSeqInstrs [
751 OR zeroh (RIImm (ImmInt 1)) dst,
752 BF cond result (ImmCLbl lbl),
753 OR zeroh (RIReg zeroh) dst,
756 returnNat (Any IntRep code__2)
758 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
759 ------------------------------------------------------------
761 getRegister (StInd pk mem)
762 = getAmode mem `thenNat` \ amode ->
764 code = amodeCode amode
765 src = amodeAddr amode
766 size = primRepToSize pk
767 code__2 dst = code . mkSeqInstr (LD size dst src)
769 returnNat (Any pk code__2)
771 getRegister (StInt i)
774 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
776 returnNat (Any IntRep code)
779 code dst = mkSeqInstr (LDI Q dst src)
781 returnNat (Any IntRep code)
783 src = ImmInt (fromInteger i)
788 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
790 returnNat (Any PtrRep code)
793 imm__2 = case imm of Just x -> x
795 #endif {- alpha_TARGET_ARCH -}
797 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
801 getRegister (StFloat f)
802 = getNatLabelNCG `thenNat` \ lbl ->
803 let code dst = toOL [
808 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
811 returnNat (Any FloatRep code)
814 getRegister (StDouble d)
817 = let code dst = unitOL (GLDZ dst)
818 in returnNat (Any DoubleRep code)
821 = let code dst = unitOL (GLD1 dst)
822 in returnNat (Any DoubleRep code)
825 = getNatLabelNCG `thenNat` \ lbl ->
826 let code dst = toOL [
829 DATA DF [ImmDouble d],
831 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
834 returnNat (Any DoubleRep code)
837 getRegister (StMachOp mop [x]) -- unary MachOps
839 MO_NatS_Neg -> trivialUCode (NEGI L) x
840 MO_Nat_Not -> trivialUCode (NOT L) x
841 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
843 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
844 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
846 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
847 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
849 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
850 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
852 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
853 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
855 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
856 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
858 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
859 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
860 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
861 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
863 -- Conversions which are a nop on x86
864 MO_NatS_to_32U -> conversionNop WordRep x
865 MO_32U_to_NatS -> conversionNop IntRep x
867 MO_NatU_to_NatS -> conversionNop IntRep x
868 MO_NatS_to_NatU -> conversionNop WordRep x
869 MO_NatP_to_NatU -> conversionNop WordRep x
870 MO_NatU_to_NatP -> conversionNop PtrRep x
871 MO_NatS_to_NatP -> conversionNop PtrRep x
872 MO_NatP_to_NatS -> conversionNop IntRep x
874 MO_Dbl_to_Flt -> conversionNop FloatRep x
875 MO_Flt_to_Dbl -> conversionNop DoubleRep x
877 -- sign-extending widenings
878 MO_8U_to_NatU -> integerExtend False 24 x
879 MO_8S_to_NatS -> integerExtend True 24 x
880 MO_16U_to_NatU -> integerExtend False 16 x
881 MO_16S_to_NatS -> integerExtend True 16 x
882 MO_8U_to_32U -> integerExtend False 24 x
886 (if is_float_op then demote else id)
887 (StCall (Left fn) CCallConv DoubleRep
888 [(if is_float_op then promote else id) x])
891 integerExtend signed nBits x
893 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
894 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
897 conversionNop new_rep expr
898 = getRegister expr `thenNat` \ e_code ->
899 returnNat (swizzleRegisterRep e_code new_rep)
901 promote x = StMachOp MO_Flt_to_Dbl [x]
902 demote x = StMachOp MO_Dbl_to_Flt [x]
905 MO_Flt_Exp -> (True, SLIT("exp"))
906 MO_Flt_Log -> (True, SLIT("log"))
908 MO_Flt_Asin -> (True, SLIT("asin"))
909 MO_Flt_Acos -> (True, SLIT("acos"))
910 MO_Flt_Atan -> (True, SLIT("atan"))
912 MO_Flt_Sinh -> (True, SLIT("sinh"))
913 MO_Flt_Cosh -> (True, SLIT("cosh"))
914 MO_Flt_Tanh -> (True, SLIT("tanh"))
916 MO_Dbl_Exp -> (False, SLIT("exp"))
917 MO_Dbl_Log -> (False, SLIT("log"))
919 MO_Dbl_Asin -> (False, SLIT("asin"))
920 MO_Dbl_Acos -> (False, SLIT("acos"))
921 MO_Dbl_Atan -> (False, SLIT("atan"))
923 MO_Dbl_Sinh -> (False, SLIT("sinh"))
924 MO_Dbl_Cosh -> (False, SLIT("cosh"))
925 MO_Dbl_Tanh -> (False, SLIT("tanh"))
927 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
931 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
933 MO_32U_Gt -> condIntReg GTT x y
934 MO_32U_Ge -> condIntReg GE x y
935 MO_32U_Eq -> condIntReg EQQ x y
936 MO_32U_Ne -> condIntReg NE x y
937 MO_32U_Lt -> condIntReg LTT x y
938 MO_32U_Le -> condIntReg LE x y
940 MO_Nat_Eq -> condIntReg EQQ x y
941 MO_Nat_Ne -> condIntReg NE x y
943 MO_NatS_Gt -> condIntReg GTT x y
944 MO_NatS_Ge -> condIntReg GE x y
945 MO_NatS_Lt -> condIntReg LTT x y
946 MO_NatS_Le -> condIntReg LE x y
948 MO_NatU_Gt -> condIntReg GU x y
949 MO_NatU_Ge -> condIntReg GEU x y
950 MO_NatU_Lt -> condIntReg LU x y
951 MO_NatU_Le -> condIntReg LEU x y
953 MO_Flt_Gt -> condFltReg GTT x y
954 MO_Flt_Ge -> condFltReg GE x y
955 MO_Flt_Eq -> condFltReg EQQ x y
956 MO_Flt_Ne -> condFltReg NE x y
957 MO_Flt_Lt -> condFltReg LTT x y
958 MO_Flt_Le -> condFltReg LE x y
960 MO_Dbl_Gt -> condFltReg GTT x y
961 MO_Dbl_Ge -> condFltReg GE x y
962 MO_Dbl_Eq -> condFltReg EQQ x y
963 MO_Dbl_Ne -> condFltReg NE x y
964 MO_Dbl_Lt -> condFltReg LTT x y
965 MO_Dbl_Le -> condFltReg LE x y
967 MO_Nat_Add -> add_code L x y
968 MO_Nat_Sub -> sub_code L x y
969 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
970 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
971 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
972 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
973 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
974 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
975 MO_NatS_MulMayOflo -> imulMayOflo x y
977 MO_Flt_Add -> trivialFCode FloatRep GADD x y
978 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
979 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
980 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
982 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
983 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
984 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
985 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
987 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
988 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
989 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
991 {- Shift ops on x86s have constraints on their source, it
992 either has to be Imm, CL or 1
993 => trivialCode's is not restrictive enough (sigh.)
995 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
996 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
997 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
999 MO_Flt_Pwr -> getRegister (demote
1000 (StCall (Left SLIT("pow")) CCallConv DoubleRep
1001 [promote x, promote y])
1003 MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
1005 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1007 promote x = StMachOp MO_Flt_to_Dbl [x]
1008 demote x = StMachOp MO_Dbl_to_Flt [x]
1010 --------------------
1011 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1013 = getNewRegNCG IntRep `thenNat` \ t1 ->
1014 getNewRegNCG IntRep `thenNat` \ t2 ->
1015 getNewRegNCG IntRep `thenNat` \ res_lo ->
1016 getNewRegNCG IntRep `thenNat` \ res_hi ->
1017 getRegister a1 `thenNat` \ reg1 ->
1018 getRegister a2 `thenNat` \ reg2 ->
1019 let code1 = registerCode reg1 t1
1020 code2 = registerCode reg2 t2
1021 src1 = registerName reg1 t1
1022 src2 = registerName reg2 t2
1023 code dst = code1 `appOL` code2 `appOL`
1025 MOV L (OpReg src1) (OpReg res_hi),
1026 MOV L (OpReg src2) (OpReg res_lo),
1027 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1028 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1029 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1030 MOV L (OpReg res_lo) (OpReg dst)
1031 -- dst==0 if high part == sign extended low part
1034 returnNat (Any IntRep code)
1036 --------------------
1037 shift_code :: (Imm -> Operand -> Instr)
1042 {- Case1: shift length as immediate -}
1043 -- Code is the same as the first eq. for trivialCode -- sigh.
1044 shift_code instr x y{-amount-}
1046 = getRegister x `thenNat` \ regx ->
1049 then registerCodeA regx dst `bind` \ code_x ->
1051 instr imm__2 (OpReg dst)
1052 else registerCodeF regx `bind` \ code_x ->
1053 registerNameF regx `bind` \ r_x ->
1055 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1056 instr imm__2 (OpReg dst)
1058 returnNat (Any IntRep mkcode)
1061 imm__2 = case imm of Just x -> x
1063 {- Case2: shift length is complex (non-immediate) -}
1064 -- Since ECX is always used as a spill temporary, we can't
1065 -- use it here to do non-immediate shifts. No big deal --
1066 -- they are only very rare, and we can use an equivalent
1067 -- test-and-jump sequence which doesn't use ECX.
1068 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1069 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1070 shift_code instr x y{-amount-}
1071 = getRegister x `thenNat` \ register1 ->
1072 getRegister y `thenNat` \ register2 ->
1073 getNatLabelNCG `thenNat` \ lbl_test3 ->
1074 getNatLabelNCG `thenNat` \ lbl_test2 ->
1075 getNatLabelNCG `thenNat` \ lbl_test1 ->
1076 getNatLabelNCG `thenNat` \ lbl_test0 ->
1077 getNatLabelNCG `thenNat` \ lbl_after ->
1078 getNewRegNCG IntRep `thenNat` \ tmp ->
1080 = let src_val = registerName register1 dst
1081 code_val = registerCode register1 dst
1082 src_amt = registerName register2 tmp
1083 code_amt = registerCode register2 tmp
1088 MOV L (OpReg src_amt) r_tmp `appOL`
1090 MOV L (OpReg src_val) r_dst `appOL`
1092 COMMENT (_PK_ "begin shift sequence"),
1093 MOV L (OpReg src_val) r_dst,
1094 MOV L (OpReg src_amt) r_tmp,
1096 BT L (ImmInt 4) r_tmp,
1098 instr (ImmInt 16) r_dst,
1101 BT L (ImmInt 3) r_tmp,
1103 instr (ImmInt 8) r_dst,
1106 BT L (ImmInt 2) r_tmp,
1108 instr (ImmInt 4) r_dst,
1111 BT L (ImmInt 1) r_tmp,
1113 instr (ImmInt 2) r_dst,
1116 BT L (ImmInt 0) r_tmp,
1118 instr (ImmInt 1) r_dst,
1121 COMMENT (_PK_ "end shift sequence")
1124 returnNat (Any IntRep code__2)
1126 --------------------
1127 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1129 add_code sz x (StInt y)
1130 = getRegister x `thenNat` \ register ->
1131 getNewRegNCG IntRep `thenNat` \ tmp ->
1133 code = registerCode register tmp
1134 src1 = registerName register tmp
1135 src2 = ImmInt (fromInteger y)
1138 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1141 returnNat (Any IntRep code__2)
1143 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1145 --------------------
1146 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1148 sub_code sz x (StInt y)
1149 = getRegister x `thenNat` \ register ->
1150 getNewRegNCG IntRep `thenNat` \ tmp ->
1152 code = registerCode register tmp
1153 src1 = registerName register tmp
1154 src2 = ImmInt (-(fromInteger y))
1157 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1160 returnNat (Any IntRep code__2)
1162 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1164 getRegister (StInd pk mem)
1165 | not (is64BitRep pk)
1166 = getAmode mem `thenNat` \ amode ->
1168 code = amodeCode amode
1169 src = amodeAddr amode
1170 size = primRepToSize pk
1171 code__2 dst = code `snocOL`
1172 if pk == DoubleRep || pk == FloatRep
1173 then GLD size src dst
1181 (OpAddr src) (OpReg dst)
1183 returnNat (Any pk code__2)
1185 getRegister (StInt i)
1187 src = ImmInt (fromInteger i)
1190 = unitOL (XOR L (OpReg dst) (OpReg dst))
1192 = unitOL (MOV L (OpImm src) (OpReg dst))
1194 returnNat (Any IntRep code)
1198 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1200 returnNat (Any PtrRep code)
1202 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1205 imm__2 = case imm of Just x -> x
1207 #endif {- i386_TARGET_ARCH -}
1209 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1211 #if sparc_TARGET_ARCH
1213 getRegister (StFloat d)
1214 = getNatLabelNCG `thenNat` \ lbl ->
1215 getNewRegNCG PtrRep `thenNat` \ tmp ->
1216 let code dst = toOL [
1217 SEGMENT DataSegment,
1219 DATA F [ImmFloat d],
1220 SEGMENT TextSegment,
1221 SETHI (HI (ImmCLbl lbl)) tmp,
1222 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1224 returnNat (Any FloatRep code)
1226 getRegister (StDouble d)
1227 = getNatLabelNCG `thenNat` \ lbl ->
1228 getNewRegNCG PtrRep `thenNat` \ tmp ->
1229 let code dst = toOL [
1230 SEGMENT DataSegment,
1232 DATA DF [ImmDouble d],
1233 SEGMENT TextSegment,
1234 SETHI (HI (ImmCLbl lbl)) tmp,
1235 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1237 returnNat (Any DoubleRep code)
1240 getRegister (StMachOp mop [x]) -- unary PrimOps
1242 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1243 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1244 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1246 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1247 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1249 MO_Dbl_to_Flt -> coerceDbl2Flt x
1250 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1252 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1253 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1254 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1255 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1257 -- Conversions which are a nop on sparc
1258 MO_32U_to_NatS -> conversionNop IntRep x
1259 MO_NatS_to_32U -> conversionNop WordRep x
1261 MO_NatU_to_NatS -> conversionNop IntRep x
1262 MO_NatS_to_NatU -> conversionNop WordRep x
1263 MO_NatP_to_NatU -> conversionNop WordRep x
1264 MO_NatU_to_NatP -> conversionNop PtrRep x
1265 MO_NatS_to_NatP -> conversionNop PtrRep x
1266 MO_NatP_to_NatS -> conversionNop IntRep x
1268 -- sign-extending widenings
1269 MO_8U_to_32U -> integerExtend False 24 x
1270 MO_8U_to_NatU -> integerExtend False 24 x
1271 MO_8S_to_NatS -> integerExtend True 24 x
1272 MO_16U_to_NatU -> integerExtend False 16 x
1273 MO_16S_to_NatS -> integerExtend True 16 x
1276 let fixed_x = if is_float_op -- promote to double
1277 then StMachOp MO_Flt_to_Dbl [x]
1280 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1282 integerExtend signed nBits x
1284 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1285 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1287 conversionNop new_rep expr
1288 = getRegister expr `thenNat` \ e_code ->
1289 returnNat (swizzleRegisterRep e_code new_rep)
1293 MO_Flt_Exp -> (True, SLIT("exp"))
1294 MO_Flt_Log -> (True, SLIT("log"))
1295 MO_Flt_Sqrt -> (True, SLIT("sqrt"))
1297 MO_Flt_Sin -> (True, SLIT("sin"))
1298 MO_Flt_Cos -> (True, SLIT("cos"))
1299 MO_Flt_Tan -> (True, SLIT("tan"))
1301 MO_Flt_Asin -> (True, SLIT("asin"))
1302 MO_Flt_Acos -> (True, SLIT("acos"))
1303 MO_Flt_Atan -> (True, SLIT("atan"))
1305 MO_Flt_Sinh -> (True, SLIT("sinh"))
1306 MO_Flt_Cosh -> (True, SLIT("cosh"))
1307 MO_Flt_Tanh -> (True, SLIT("tanh"))
1309 MO_Dbl_Exp -> (False, SLIT("exp"))
1310 MO_Dbl_Log -> (False, SLIT("log"))
1311 MO_Dbl_Sqrt -> (False, SLIT("sqrt"))
1313 MO_Dbl_Sin -> (False, SLIT("sin"))
1314 MO_Dbl_Cos -> (False, SLIT("cos"))
1315 MO_Dbl_Tan -> (False, SLIT("tan"))
1317 MO_Dbl_Asin -> (False, SLIT("asin"))
1318 MO_Dbl_Acos -> (False, SLIT("acos"))
1319 MO_Dbl_Atan -> (False, SLIT("atan"))
1321 MO_Dbl_Sinh -> (False, SLIT("sinh"))
1322 MO_Dbl_Cosh -> (False, SLIT("cosh"))
1323 MO_Dbl_Tanh -> (False, SLIT("tanh"))
1325 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1329 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1331 MO_32U_Gt -> condIntReg GTT x y
1332 MO_32U_Ge -> condIntReg GE x y
1333 MO_32U_Eq -> condIntReg EQQ x y
1334 MO_32U_Ne -> condIntReg NE x y
1335 MO_32U_Lt -> condIntReg LTT x y
1336 MO_32U_Le -> condIntReg LE x y
1338 MO_Nat_Eq -> condIntReg EQQ x y
1339 MO_Nat_Ne -> condIntReg NE x y
1341 MO_NatS_Gt -> condIntReg GTT x y
1342 MO_NatS_Ge -> condIntReg GE x y
1343 MO_NatS_Lt -> condIntReg LTT x y
1344 MO_NatS_Le -> condIntReg LE x y
1346 MO_NatU_Gt -> condIntReg GU x y
1347 MO_NatU_Ge -> condIntReg GEU x y
1348 MO_NatU_Lt -> condIntReg LU x y
1349 MO_NatU_Le -> condIntReg LEU x y
1351 MO_Flt_Gt -> condFltReg GTT x y
1352 MO_Flt_Ge -> condFltReg GE x y
1353 MO_Flt_Eq -> condFltReg EQQ x y
1354 MO_Flt_Ne -> condFltReg NE x y
1355 MO_Flt_Lt -> condFltReg LTT x y
1356 MO_Flt_Le -> condFltReg LE x y
1358 MO_Dbl_Gt -> condFltReg GTT x y
1359 MO_Dbl_Ge -> condFltReg GE x y
1360 MO_Dbl_Eq -> condFltReg EQQ x y
1361 MO_Dbl_Ne -> condFltReg NE x y
1362 MO_Dbl_Lt -> condFltReg LTT x y
1363 MO_Dbl_Le -> condFltReg LE x y
1365 MO_Nat_Add -> trivialCode (ADD False False) x y
1366 MO_Nat_Sub -> trivialCode (SUB False False) x y
1368 MO_NatS_Mul -> trivialCode (SMUL False) x y
1369 MO_NatU_Mul -> trivialCode (UMUL False) x y
1370 MO_NatS_MulMayOflo -> imulMayOflo x y
1372 -- ToDo: teach about V8+ SPARC div instructions
1373 MO_NatS_Quot -> idiv SLIT(".div") x y
1374 MO_NatS_Rem -> idiv SLIT(".rem") x y
1375 MO_NatU_Quot -> idiv SLIT(".udiv") x y
1376 MO_NatU_Rem -> idiv SLIT(".urem") x y
1378 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1379 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1380 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1381 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1383 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1384 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1385 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1386 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1388 MO_Nat_And -> trivialCode (AND False) x y
1389 MO_Nat_Or -> trivialCode (OR False) x y
1390 MO_Nat_Xor -> trivialCode (XOR False) x y
1392 MO_Nat_Shl -> trivialCode SLL x y
1393 MO_Nat_Shr -> trivialCode SRL x y
1394 MO_Nat_Sar -> trivialCode SRA x y
1396 MO_Flt_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
1397 [promote x, promote y])
1398 where promote x = StMachOp MO_Flt_to_Dbl [x]
1399 MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
1402 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1404 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1406 --------------------
1407 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1409 = getNewRegNCG IntRep `thenNat` \ t1 ->
1410 getNewRegNCG IntRep `thenNat` \ t2 ->
1411 getNewRegNCG IntRep `thenNat` \ res_lo ->
1412 getNewRegNCG IntRep `thenNat` \ res_hi ->
1413 getRegister a1 `thenNat` \ reg1 ->
1414 getRegister a2 `thenNat` \ reg2 ->
1415 let code1 = registerCode reg1 t1
1416 code2 = registerCode reg2 t2
1417 src1 = registerName reg1 t1
1418 src2 = registerName reg2 t2
1419 code dst = code1 `appOL` code2 `appOL`
1421 SMUL False src1 (RIReg src2) res_lo,
1423 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1424 SUB False False res_lo (RIReg res_hi) dst
1427 returnNat (Any IntRep code)
1429 getRegister (StInd pk mem)
1430 = getAmode mem `thenNat` \ amode ->
1432 code = amodeCode amode
1433 src = amodeAddr amode
1434 size = primRepToSize pk
1435 code__2 dst = code `snocOL` LD size src dst
1437 returnNat (Any pk code__2)
1439 getRegister (StInt i)
1442 src = ImmInt (fromInteger i)
1443 code dst = unitOL (OR False g0 (RIImm src) dst)
1445 returnNat (Any IntRep code)
1451 SETHI (HI imm__2) dst,
1452 OR False dst (RIImm (LO imm__2)) dst]
1454 returnNat (Any PtrRep code)
1456 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1459 imm__2 = case imm of Just x -> x
1461 #endif {- sparc_TARGET_ARCH -}
1463 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1467 %************************************************************************
1469 \subsection{The @Amode@ type}
1471 %************************************************************************
1473 @Amode@s: Memory addressing modes passed up the tree.
1475 data Amode = Amode MachRegsAddr InstrBlock
1477 amodeAddr (Amode addr _) = addr
1478 amodeCode (Amode _ code) = code
1481 Now, given a tree (the argument to an StInd) that references memory,
1482 produce a suitable addressing mode.
1484 A Rule of the Game (tm) for Amodes: use of the addr bit must
1485 immediately follow use of the code part, since the code part puts
1486 values in registers which the addr then refers to. So you can't put
1487 anything in between, lest it overwrite some of those registers. If
1488 you need to do some other computation between the code part and use of
1489 the addr bit, first store the effective address from the amode in a
1490 temporary, then do the other computation, and then use the temporary:
1494 ... other computation ...
1498 getAmode :: StixExpr -> NatM Amode
1500 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1502 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1504 #if alpha_TARGET_ARCH
1506 getAmode (StPrim IntSubOp [x, StInt i])
1507 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1508 getRegister x `thenNat` \ register ->
1510 code = registerCode register tmp
1511 reg = registerName register tmp
1512 off = ImmInt (-(fromInteger i))
1514 returnNat (Amode (AddrRegImm reg off) code)
1516 getAmode (StPrim IntAddOp [x, StInt i])
1517 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1518 getRegister x `thenNat` \ register ->
1520 code = registerCode register tmp
1521 reg = registerName register tmp
1522 off = ImmInt (fromInteger i)
1524 returnNat (Amode (AddrRegImm reg off) code)
1528 = returnNat (Amode (AddrImm imm__2) id)
1531 imm__2 = case imm of Just x -> x
1534 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1535 getRegister other `thenNat` \ register ->
1537 code = registerCode register tmp
1538 reg = registerName register tmp
1540 returnNat (Amode (AddrReg reg) code)
1542 #endif {- alpha_TARGET_ARCH -}
1544 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1546 #if i386_TARGET_ARCH
1548 -- This is all just ridiculous, since it carefully undoes
1549 -- what mangleIndexTree has just done.
1550 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1551 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1552 getRegister x `thenNat` \ register ->
1554 code = registerCode register tmp
1555 reg = registerName register tmp
1556 off = ImmInt (-(fromInteger i))
1558 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1560 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1562 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1565 imm__2 = case imm of Just x -> x
1567 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1568 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1569 getRegister x `thenNat` \ register ->
1571 code = registerCode register tmp
1572 reg = registerName register tmp
1573 off = ImmInt (fromInteger i)
1575 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1577 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1578 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1579 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1580 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1581 getRegister x `thenNat` \ register1 ->
1582 getRegister y `thenNat` \ register2 ->
1584 code1 = registerCode register1 tmp1
1585 reg1 = registerName register1 tmp1
1586 code2 = registerCode register2 tmp2
1587 reg2 = registerName register2 tmp2
1588 code__2 = code1 `appOL` code2
1589 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1591 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1596 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1599 imm__2 = case imm of Just x -> x
1602 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1603 getRegister other `thenNat` \ register ->
1605 code = registerCode register tmp
1606 reg = registerName register tmp
1608 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1610 #endif {- i386_TARGET_ARCH -}
1612 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1614 #if sparc_TARGET_ARCH
1616 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1618 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1619 getRegister x `thenNat` \ register ->
1621 code = registerCode register tmp
1622 reg = registerName register tmp
1623 off = ImmInt (-(fromInteger i))
1625 returnNat (Amode (AddrRegImm reg off) code)
1628 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1630 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1631 getRegister x `thenNat` \ register ->
1633 code = registerCode register tmp
1634 reg = registerName register tmp
1635 off = ImmInt (fromInteger i)
1637 returnNat (Amode (AddrRegImm reg off) code)
1639 getAmode (StMachOp MO_Nat_Add [x, y])
1640 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1641 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1642 getRegister x `thenNat` \ register1 ->
1643 getRegister y `thenNat` \ register2 ->
1645 code1 = registerCode register1 tmp1
1646 reg1 = registerName register1 tmp1
1647 code2 = registerCode register2 tmp2
1648 reg2 = registerName register2 tmp2
1649 code__2 = code1 `appOL` code2
1651 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1655 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1657 code = unitOL (SETHI (HI imm__2) tmp)
1659 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1662 imm__2 = case imm of Just x -> x
1665 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1666 getRegister other `thenNat` \ register ->
1668 code = registerCode register tmp
1669 reg = registerName register tmp
1672 returnNat (Amode (AddrRegImm reg off) code)
1674 #endif {- sparc_TARGET_ARCH -}
1676 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1679 %************************************************************************
1681 \subsection{The @CondCode@ type}
1683 %************************************************************************
1685 Condition codes passed up the tree.
1687 data CondCode = CondCode Bool Cond InstrBlock
1689 condName (CondCode _ cond _) = cond
1690 condFloat (CondCode is_float _ _) = is_float
1691 condCode (CondCode _ _ code) = code
1694 Set up a condition code for a conditional branch.
1697 getCondCode :: StixExpr -> NatM CondCode
1699 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1701 #if alpha_TARGET_ARCH
1702 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1703 #endif {- alpha_TARGET_ARCH -}
1705 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1707 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1708 -- yes, they really do seem to want exactly the same!
1710 getCondCode (StMachOp mop [x, y])
1712 MO_32U_Gt -> condIntCode GTT x y
1713 MO_32U_Ge -> condIntCode GE x y
1714 MO_32U_Eq -> condIntCode EQQ x y
1715 MO_32U_Ne -> condIntCode NE x y
1716 MO_32U_Lt -> condIntCode LTT x y
1717 MO_32U_Le -> condIntCode LE x y
1719 MO_Nat_Eq -> condIntCode EQQ x y
1720 MO_Nat_Ne -> condIntCode NE x y
1722 MO_NatS_Gt -> condIntCode GTT x y
1723 MO_NatS_Ge -> condIntCode GE x y
1724 MO_NatS_Lt -> condIntCode LTT x y
1725 MO_NatS_Le -> condIntCode LE x y
1727 MO_NatU_Gt -> condIntCode GU x y
1728 MO_NatU_Ge -> condIntCode GEU x y
1729 MO_NatU_Lt -> condIntCode LU x y
1730 MO_NatU_Le -> condIntCode LEU x y
1732 MO_Flt_Gt -> condFltCode GTT x y
1733 MO_Flt_Ge -> condFltCode GE x y
1734 MO_Flt_Eq -> condFltCode EQQ x y
1735 MO_Flt_Ne -> condFltCode NE x y
1736 MO_Flt_Lt -> condFltCode LTT x y
1737 MO_Flt_Le -> condFltCode LE x y
1739 MO_Dbl_Gt -> condFltCode GTT x y
1740 MO_Dbl_Ge -> condFltCode GE x y
1741 MO_Dbl_Eq -> condFltCode EQQ x y
1742 MO_Dbl_Ne -> condFltCode NE x y
1743 MO_Dbl_Lt -> condFltCode LTT x y
1744 MO_Dbl_Le -> condFltCode LE x y
1746 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1748 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1750 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1752 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1757 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1758 passed back up the tree.
1761 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1763 #if alpha_TARGET_ARCH
1764 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1765 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1766 #endif {- alpha_TARGET_ARCH -}
1768 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1769 #if i386_TARGET_ARCH
1771 -- memory vs immediate
1772 condIntCode cond (StInd pk x) y
1773 | Just i <- maybeImm y
1774 = getAmode x `thenNat` \ amode ->
1776 code1 = amodeCode amode
1777 x__2 = amodeAddr amode
1778 sz = primRepToSize pk
1779 code__2 = code1 `snocOL`
1780 CMP sz (OpImm i) (OpAddr x__2)
1782 returnNat (CondCode False cond code__2)
1785 condIntCode cond x (StInt 0)
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 TEST L (OpReg src1) (OpReg src1)
1794 returnNat (CondCode False cond code__2)
1796 -- anything vs immediate
1797 condIntCode cond x y
1798 | Just i <- maybeImm y
1799 = getRegister x `thenNat` \ register1 ->
1800 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1802 code1 = registerCode register1 tmp1
1803 src1 = registerName register1 tmp1
1804 code__2 = code1 `snocOL`
1805 CMP L (OpImm i) (OpReg src1)
1807 returnNat (CondCode False cond code__2)
1809 -- memory vs anything
1810 condIntCode cond (StInd pk x) y
1811 = getAmode x `thenNat` \ amode_x ->
1812 getRegister y `thenNat` \ reg_y ->
1813 getNewRegNCG IntRep `thenNat` \ tmp ->
1815 c_x = amodeCode amode_x
1816 am_x = amodeAddr amode_x
1817 c_y = registerCode reg_y tmp
1818 r_y = registerName reg_y tmp
1819 sz = primRepToSize pk
1821 -- optimisation: if there's no code for x, just an amode,
1822 -- use whatever reg y winds up in. Assumes that c_y doesn't
1823 -- clobber any regs in the amode am_x, which I'm not sure is
1824 -- justified. The otherwise clause makes the same assumption.
1825 code__2 | isNilOL c_x
1827 CMP sz (OpReg r_y) (OpAddr am_x)
1831 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1833 CMP sz (OpReg tmp) (OpAddr am_x)
1835 returnNat (CondCode False cond code__2)
1837 -- anything vs memory
1839 condIntCode cond y (StInd pk x)
1840 = getAmode x `thenNat` \ amode_x ->
1841 getRegister y `thenNat` \ reg_y ->
1842 getNewRegNCG IntRep `thenNat` \ tmp ->
1844 c_x = amodeCode amode_x
1845 am_x = amodeAddr amode_x
1846 c_y = registerCode reg_y tmp
1847 r_y = registerName reg_y tmp
1848 sz = primRepToSize pk
1849 -- same optimisation and nagging doubts as previous clause
1850 code__2 | isNilOL c_x
1852 CMP sz (OpAddr am_x) (OpReg r_y)
1856 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1858 CMP sz (OpAddr am_x) (OpReg tmp)
1860 returnNat (CondCode False cond code__2)
1862 -- anything vs anything
1863 condIntCode cond x y
1864 = getRegister x `thenNat` \ register1 ->
1865 getRegister y `thenNat` \ register2 ->
1866 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1867 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1869 code1 = registerCode register1 tmp1
1870 src1 = registerName register1 tmp1
1871 code2 = registerCode register2 tmp2
1872 src2 = registerName register2 tmp2
1873 code__2 = code1 `snocOL`
1874 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1876 CMP L (OpReg src2) (OpReg tmp1)
1878 returnNat (CondCode False cond code__2)
1881 condFltCode cond x y
1882 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1883 getRegister x `thenNat` \ register1 ->
1884 getRegister y `thenNat` \ register2 ->
1885 getNewRegNCG (registerRep register1)
1887 getNewRegNCG (registerRep register2)
1889 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1891 code1 = registerCode register1 tmp1
1892 src1 = registerName register1 tmp1
1894 code2 = registerCode register2 tmp2
1895 src2 = registerName register2 tmp2
1897 code__2 | isAny register1
1898 = code1 `appOL` -- result in tmp1
1904 GMOV src1 tmp1 `appOL`
1908 -- The GCMP insn does the test and sets the zero flag if comparable
1909 -- and true. Hence we always supply EQQ as the condition to test.
1910 returnNat (CondCode True EQQ code__2)
1912 #endif {- i386_TARGET_ARCH -}
1914 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1916 #if sparc_TARGET_ARCH
1918 condIntCode cond x (StInt y)
1920 = getRegister x `thenNat` \ register ->
1921 getNewRegNCG IntRep `thenNat` \ tmp ->
1923 code = registerCode register tmp
1924 src1 = registerName register tmp
1925 src2 = ImmInt (fromInteger y)
1926 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1928 returnNat (CondCode False cond code__2)
1930 condIntCode cond x y
1931 = getRegister x `thenNat` \ register1 ->
1932 getRegister y `thenNat` \ register2 ->
1933 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1934 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1936 code1 = registerCode register1 tmp1
1937 src1 = registerName register1 tmp1
1938 code2 = registerCode register2 tmp2
1939 src2 = registerName register2 tmp2
1940 code__2 = code1 `appOL` code2 `snocOL`
1941 SUB False True src1 (RIReg src2) g0
1943 returnNat (CondCode False cond code__2)
1946 condFltCode cond x y
1947 = getRegister x `thenNat` \ register1 ->
1948 getRegister y `thenNat` \ register2 ->
1949 getNewRegNCG (registerRep register1)
1951 getNewRegNCG (registerRep register2)
1953 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1955 promote x = FxTOy F DF x tmp
1957 pk1 = registerRep register1
1958 code1 = registerCode register1 tmp1
1959 src1 = registerName register1 tmp1
1961 pk2 = registerRep register2
1962 code2 = registerCode register2 tmp2
1963 src2 = registerName register2 tmp2
1967 code1 `appOL` code2 `snocOL`
1968 FCMP True (primRepToSize pk1) src1 src2
1969 else if pk1 == FloatRep then
1970 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1971 FCMP True DF tmp src2
1973 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1974 FCMP True DF src1 tmp
1976 returnNat (CondCode True cond code__2)
1978 #endif {- sparc_TARGET_ARCH -}
1980 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1983 %************************************************************************
1985 \subsection{Generating assignments}
1987 %************************************************************************
1989 Assignments are really at the heart of the whole code generation
1990 business. Almost all top-level nodes of any real importance are
1991 assignments, which correspond to loads, stores, or register transfers.
1992 If we're really lucky, some of the register transfers will go away,
1993 because we can use the destination register to complete the code
1994 generation for the right hand side. This only fails when the right
1995 hand side is forced into a fixed register (e.g. the result of a call).
1998 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1999 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2001 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2002 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2004 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2006 #if alpha_TARGET_ARCH
2008 assignIntCode pk (StInd _ dst) src
2009 = getNewRegNCG IntRep `thenNat` \ tmp ->
2010 getAmode dst `thenNat` \ amode ->
2011 getRegister src `thenNat` \ register ->
2013 code1 = amodeCode amode []
2014 dst__2 = amodeAddr amode
2015 code2 = registerCode register tmp []
2016 src__2 = registerName register tmp
2017 sz = primRepToSize pk
2018 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2022 assignIntCode pk dst src
2023 = getRegister dst `thenNat` \ register1 ->
2024 getRegister src `thenNat` \ register2 ->
2026 dst__2 = registerName register1 zeroh
2027 code = registerCode register2 dst__2
2028 src__2 = registerName register2 dst__2
2029 code__2 = if isFixed register2
2030 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2035 #endif {- alpha_TARGET_ARCH -}
2037 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2039 #if i386_TARGET_ARCH
2041 -- non-FP assignment to memory
2042 assignMem_IntCode pk addr src
2043 = getAmode addr `thenNat` \ amode ->
2044 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2045 getNewRegNCG PtrRep `thenNat` \ tmp ->
2047 -- In general, if the address computation for dst may require
2048 -- some insns preceding the addressing mode itself. So there's
2049 -- no guarantee that the code for dst and the code for src won't
2050 -- write the same register. This means either the address or
2051 -- the value needs to be copied into a temporary. We detect the
2052 -- common case where the amode has no code, and elide the copy.
2053 codea = amodeCode amode
2054 dst__a = amodeAddr amode
2056 code | isNilOL codea
2058 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2061 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2063 MOV (primRepToSize pk) opsrc
2064 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2070 -> NatM (InstrBlock,Operand) -- code, operator
2073 | Just x <- maybeImm op
2074 = returnNat (nilOL, OpImm x)
2077 = getRegister op `thenNat` \ register ->
2078 getNewRegNCG (registerRep register)
2080 let code = registerCode register tmp
2081 reg = registerName register tmp
2083 returnNat (code, OpReg reg)
2085 -- Assign; dst is a reg, rhs is mem
2086 assignReg_IntCode pk reg (StInd pks src)
2087 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2088 getAmode src `thenNat` \ amode ->
2089 getRegisterReg reg `thenNat` \ reg_dst ->
2091 c_addr = amodeCode amode
2092 am_addr = amodeAddr amode
2093 r_dst = registerName reg_dst tmp
2094 szs = primRepToSize pks
2103 code = c_addr `snocOL`
2104 opc (OpAddr am_addr) (OpReg r_dst)
2108 -- dst is a reg, but src could be anything
2109 assignReg_IntCode pk reg src
2110 = getRegisterReg reg `thenNat` \ registerd ->
2111 getRegister src `thenNat` \ registers ->
2112 getNewRegNCG IntRep `thenNat` \ tmp ->
2114 r_dst = registerName registerd tmp
2115 r_src = registerName registers r_dst
2116 c_src = registerCode registers r_dst
2118 code = c_src `snocOL`
2119 MOV L (OpReg r_src) (OpReg r_dst)
2123 #endif {- i386_TARGET_ARCH -}
2125 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2127 #if sparc_TARGET_ARCH
2129 assignMem_IntCode pk addr src
2130 = getNewRegNCG IntRep `thenNat` \ tmp ->
2131 getAmode addr `thenNat` \ amode ->
2132 getRegister src `thenNat` \ register ->
2134 code1 = amodeCode amode
2135 dst__2 = amodeAddr amode
2136 code2 = registerCode register tmp
2137 src__2 = registerName register tmp
2138 sz = primRepToSize pk
2139 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2143 assignReg_IntCode pk reg src
2144 = getRegister src `thenNat` \ register2 ->
2145 getRegisterReg reg `thenNat` \ register1 ->
2147 dst__2 = registerName register1 g0
2148 code = registerCode register2 dst__2
2149 src__2 = registerName register2 dst__2
2150 code__2 = if isFixed register2
2151 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2156 #endif {- sparc_TARGET_ARCH -}
2158 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2161 % --------------------------------
2162 Floating-point assignments:
2163 % --------------------------------
2166 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2167 #if alpha_TARGET_ARCH
2169 assignFltCode pk (StInd _ dst) src
2170 = getNewRegNCG pk `thenNat` \ tmp ->
2171 getAmode dst `thenNat` \ amode ->
2172 getRegister src `thenNat` \ register ->
2174 code1 = amodeCode amode []
2175 dst__2 = amodeAddr amode
2176 code2 = registerCode register tmp []
2177 src__2 = registerName register tmp
2178 sz = primRepToSize pk
2179 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2183 assignFltCode pk dst src
2184 = getRegister dst `thenNat` \ register1 ->
2185 getRegister src `thenNat` \ register2 ->
2187 dst__2 = registerName register1 zeroh
2188 code = registerCode register2 dst__2
2189 src__2 = registerName register2 dst__2
2190 code__2 = if isFixed register2
2191 then code . mkSeqInstr (FMOV src__2 dst__2)
2196 #endif {- alpha_TARGET_ARCH -}
2198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2200 #if i386_TARGET_ARCH
2202 -- Floating point assignment to memory
2203 assignMem_FltCode pk addr src
2204 = getRegister src `thenNat` \ reg_src ->
2205 getRegister addr `thenNat` \ reg_addr ->
2206 getNewRegNCG pk `thenNat` \ tmp_src ->
2207 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2208 let r_src = registerName reg_src tmp_src
2209 c_src = registerCode reg_src tmp_src
2210 r_addr = registerName reg_addr tmp_addr
2211 c_addr = registerCode reg_addr tmp_addr
2212 sz = primRepToSize pk
2214 code = c_src `appOL`
2215 -- no need to preserve r_src across the addr computation,
2216 -- since r_src must be a float reg
2217 -- whilst r_addr is an int reg
2220 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2224 -- Floating point assignment to a register/temporary
2225 assignReg_FltCode pk reg src
2226 = getRegisterReg reg `thenNat` \ reg_dst ->
2227 getRegister src `thenNat` \ reg_src ->
2228 getNewRegNCG pk `thenNat` \ tmp ->
2230 r_dst = registerName reg_dst tmp
2231 r_src = registerName reg_src r_dst
2232 c_src = registerCode reg_src r_dst
2234 code = if isFixed reg_src
2235 then c_src `snocOL` GMOV r_src r_dst
2241 #endif {- i386_TARGET_ARCH -}
2243 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2245 #if sparc_TARGET_ARCH
2247 -- Floating point assignment to memory
2248 assignMem_FltCode pk addr src
2249 = getNewRegNCG pk `thenNat` \ tmp1 ->
2250 getAmode addr `thenNat` \ amode ->
2251 getRegister src `thenNat` \ register ->
2253 sz = primRepToSize pk
2254 dst__2 = amodeAddr amode
2256 code1 = amodeCode amode
2257 code2 = registerCode register tmp1
2259 src__2 = registerName register tmp1
2260 pk__2 = registerRep register
2261 sz__2 = primRepToSize pk__2
2263 code__2 = code1 `appOL` code2 `appOL`
2265 then unitOL (ST sz src__2 dst__2)
2266 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2270 -- Floating point assignment to a register/temporary
2271 -- Why is this so bizarrely ugly?
2272 assignReg_FltCode pk reg src
2273 = getRegisterReg reg `thenNat` \ register1 ->
2274 getRegister src `thenNat` \ register2 ->
2276 pk__2 = registerRep register2
2277 sz__2 = primRepToSize pk__2
2279 getNewRegNCG pk__2 `thenNat` \ tmp ->
2281 sz = primRepToSize pk
2282 dst__2 = registerName register1 g0 -- must be Fixed
2283 reg__2 = if pk /= pk__2 then tmp else dst__2
2284 code = registerCode register2 reg__2
2285 src__2 = registerName register2 reg__2
2288 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2289 else if isFixed register2 then
2290 code `snocOL` FMOV sz src__2 dst__2
2296 #endif {- sparc_TARGET_ARCH -}
2298 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2301 %************************************************************************
2303 \subsection{Generating an unconditional branch}
2305 %************************************************************************
2307 We accept two types of targets: an immediate CLabel or a tree that
2308 gets evaluated into a register. Any CLabels which are AsmTemporaries
2309 are assumed to be in the local block of code, close enough for a
2310 branch instruction. Other CLabels are assumed to be far away.
2312 (If applicable) Do not fill the delay slots here; you will confuse the
2316 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2318 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2320 #if alpha_TARGET_ARCH
2322 genJump (StCLbl lbl)
2323 | isAsmTemp lbl = returnInstr (BR target)
2324 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2326 target = ImmCLbl lbl
2329 = getRegister tree `thenNat` \ register ->
2330 getNewRegNCG PtrRep `thenNat` \ tmp ->
2332 dst = registerName register pv
2333 code = registerCode register pv
2334 target = registerName register pv
2336 if isFixed register then
2337 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2339 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2341 #endif {- alpha_TARGET_ARCH -}
2343 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2345 #if i386_TARGET_ARCH
2347 genJump dsts (StInd pk mem)
2348 = getAmode mem `thenNat` \ amode ->
2350 code = amodeCode amode
2351 target = amodeAddr amode
2353 returnNat (code `snocOL` JMP dsts (OpAddr target))
2357 = returnNat (unitOL (JMP dsts (OpImm target)))
2360 = getRegister tree `thenNat` \ register ->
2361 getNewRegNCG PtrRep `thenNat` \ tmp ->
2363 code = registerCode register tmp
2364 target = registerName register tmp
2366 returnNat (code `snocOL` JMP dsts (OpReg target))
2369 target = case imm of Just x -> x
2371 #endif {- i386_TARGET_ARCH -}
2373 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2375 #if sparc_TARGET_ARCH
2377 genJump dsts (StCLbl lbl)
2378 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2379 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2380 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2382 target = ImmCLbl lbl
2385 = getRegister tree `thenNat` \ register ->
2386 getNewRegNCG PtrRep `thenNat` \ tmp ->
2388 code = registerCode register tmp
2389 target = registerName register tmp
2391 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2393 #endif {- sparc_TARGET_ARCH -}
2395 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2398 %************************************************************************
2400 \subsection{Conditional jumps}
2402 %************************************************************************
2404 Conditional jumps are always to local labels, so we can use branch
2405 instructions. We peek at the arguments to decide what kind of
2408 ALPHA: For comparisons with 0, we're laughing, because we can just do
2409 the desired conditional branch.
2411 I386: First, we have to ensure that the condition
2412 codes are set according to the supplied comparison operation.
2414 SPARC: First, we have to ensure that the condition codes are set
2415 according to the supplied comparison operation. We generate slightly
2416 different code for floating point comparisons, because a floating
2417 point operation cannot directly precede a @BF@. We assume the worst
2418 and fill that slot with a @NOP@.
2420 SPARC: Do not fill the delay slots here; you will confuse the register
2425 :: CLabel -- the branch target
2426 -> StixExpr -- the condition on which to branch
2429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2431 #if alpha_TARGET_ARCH
2433 genCondJump lbl (StPrim op [x, StInt 0])
2434 = getRegister x `thenNat` \ register ->
2435 getNewRegNCG (registerRep register)
2438 code = registerCode register tmp
2439 value = registerName register tmp
2440 pk = registerRep register
2441 target = ImmCLbl lbl
2443 returnSeq code [BI (cmpOp op) value target]
2445 cmpOp CharGtOp = GTT
2447 cmpOp CharEqOp = EQQ
2449 cmpOp CharLtOp = LTT
2458 cmpOp WordGeOp = ALWAYS
2459 cmpOp WordEqOp = EQQ
2461 cmpOp WordLtOp = NEVER
2462 cmpOp WordLeOp = EQQ
2464 cmpOp AddrGeOp = ALWAYS
2465 cmpOp AddrEqOp = EQQ
2467 cmpOp AddrLtOp = NEVER
2468 cmpOp AddrLeOp = EQQ
2470 genCondJump lbl (StPrim op [x, StDouble 0.0])
2471 = getRegister x `thenNat` \ register ->
2472 getNewRegNCG (registerRep register)
2475 code = registerCode register tmp
2476 value = registerName register tmp
2477 pk = registerRep register
2478 target = ImmCLbl lbl
2480 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2482 cmpOp FloatGtOp = GTT
2483 cmpOp FloatGeOp = GE
2484 cmpOp FloatEqOp = EQQ
2485 cmpOp FloatNeOp = NE
2486 cmpOp FloatLtOp = LTT
2487 cmpOp FloatLeOp = LE
2488 cmpOp DoubleGtOp = GTT
2489 cmpOp DoubleGeOp = GE
2490 cmpOp DoubleEqOp = EQQ
2491 cmpOp DoubleNeOp = NE
2492 cmpOp DoubleLtOp = LTT
2493 cmpOp DoubleLeOp = LE
2495 genCondJump lbl (StPrim op [x, y])
2497 = trivialFCode pr instr x y `thenNat` \ register ->
2498 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2500 code = registerCode register tmp
2501 result = registerName register tmp
2502 target = ImmCLbl lbl
2504 returnNat (code . mkSeqInstr (BF cond result target))
2506 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2508 fltCmpOp op = case op of
2522 (instr, cond) = case op of
2523 FloatGtOp -> (FCMP TF LE, EQQ)
2524 FloatGeOp -> (FCMP TF LTT, EQQ)
2525 FloatEqOp -> (FCMP TF EQQ, NE)
2526 FloatNeOp -> (FCMP TF EQQ, EQQ)
2527 FloatLtOp -> (FCMP TF LTT, NE)
2528 FloatLeOp -> (FCMP TF LE, NE)
2529 DoubleGtOp -> (FCMP TF LE, EQQ)
2530 DoubleGeOp -> (FCMP TF LTT, EQQ)
2531 DoubleEqOp -> (FCMP TF EQQ, NE)
2532 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2533 DoubleLtOp -> (FCMP TF LTT, NE)
2534 DoubleLeOp -> (FCMP TF LE, NE)
2536 genCondJump lbl (StPrim op [x, y])
2537 = trivialCode instr x y `thenNat` \ register ->
2538 getNewRegNCG IntRep `thenNat` \ tmp ->
2540 code = registerCode register tmp
2541 result = registerName register tmp
2542 target = ImmCLbl lbl
2544 returnNat (code . mkSeqInstr (BI cond result target))
2546 (instr, cond) = case op of
2547 CharGtOp -> (CMP LE, EQQ)
2548 CharGeOp -> (CMP LTT, EQQ)
2549 CharEqOp -> (CMP EQQ, NE)
2550 CharNeOp -> (CMP EQQ, EQQ)
2551 CharLtOp -> (CMP LTT, NE)
2552 CharLeOp -> (CMP LE, NE)
2553 IntGtOp -> (CMP LE, EQQ)
2554 IntGeOp -> (CMP LTT, EQQ)
2555 IntEqOp -> (CMP EQQ, NE)
2556 IntNeOp -> (CMP EQQ, EQQ)
2557 IntLtOp -> (CMP LTT, NE)
2558 IntLeOp -> (CMP LE, NE)
2559 WordGtOp -> (CMP ULE, EQQ)
2560 WordGeOp -> (CMP ULT, EQQ)
2561 WordEqOp -> (CMP EQQ, NE)
2562 WordNeOp -> (CMP EQQ, EQQ)
2563 WordLtOp -> (CMP ULT, NE)
2564 WordLeOp -> (CMP ULE, NE)
2565 AddrGtOp -> (CMP ULE, EQQ)
2566 AddrGeOp -> (CMP ULT, EQQ)
2567 AddrEqOp -> (CMP EQQ, NE)
2568 AddrNeOp -> (CMP EQQ, EQQ)
2569 AddrLtOp -> (CMP ULT, NE)
2570 AddrLeOp -> (CMP ULE, NE)
2572 #endif {- alpha_TARGET_ARCH -}
2574 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2576 #if i386_TARGET_ARCH
2578 genCondJump lbl bool
2579 = getCondCode bool `thenNat` \ condition ->
2581 code = condCode condition
2582 cond = condName condition
2584 returnNat (code `snocOL` JXX cond lbl)
2586 #endif {- i386_TARGET_ARCH -}
2588 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2590 #if sparc_TARGET_ARCH
2592 genCondJump lbl bool
2593 = getCondCode bool `thenNat` \ condition ->
2595 code = condCode condition
2596 cond = condName condition
2597 target = ImmCLbl lbl
2602 if condFloat condition
2603 then [NOP, BF cond False target, NOP]
2604 else [BI cond False target, NOP]
2608 #endif {- sparc_TARGET_ARCH -}
2610 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2613 %************************************************************************
2615 \subsection{Generating C calls}
2617 %************************************************************************
2619 Now the biggest nightmare---calls. Most of the nastiness is buried in
2620 @get_arg@, which moves the arguments to the correct registers/stack
2621 locations. Apart from that, the code is easy.
2623 (If applicable) Do not fill the delay slots here; you will confuse the
2628 :: (Either FAST_STRING StixExpr) -- function to call
2630 -> PrimRep -- type of the result
2631 -> [StixExpr] -- arguments (of mixed type)
2634 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2636 #if alpha_TARGET_ARCH
2638 genCCall fn cconv kind args
2639 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2640 `thenNat` \ ((unused,_), argCode) ->
2642 nRegs = length allArgRegs - length unused
2643 code = asmSeqThen (map ($ []) argCode)
2646 LDA pv (AddrImm (ImmLab (ptext fn))),
2647 JSR ra (AddrReg pv) nRegs,
2648 LDGP gp (AddrReg ra)]
2650 ------------------------
2651 {- Try to get a value into a specific register (or registers) for
2652 a call. The first 6 arguments go into the appropriate
2653 argument register (separate registers for integer and floating
2654 point arguments, but used in lock-step), and the remaining
2655 arguments are dumped to the stack, beginning at 0(sp). Our
2656 first argument is a pair of the list of remaining argument
2657 registers to be assigned for this call and the next stack
2658 offset to use for overflowing arguments. This way,
2659 @get_Arg@ can be applied to all of a call's arguments using
2663 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2664 -> StixTree -- Current argument
2665 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2667 -- We have to use up all of our argument registers first...
2669 get_arg ((iDst,fDst):dsts, offset) arg
2670 = getRegister arg `thenNat` \ register ->
2672 reg = if isFloatingRep pk then fDst else iDst
2673 code = registerCode register reg
2674 src = registerName register reg
2675 pk = registerRep register
2678 if isFloatingRep pk then
2679 ((dsts, offset), if isFixed register then
2680 code . mkSeqInstr (FMOV src fDst)
2683 ((dsts, offset), if isFixed register then
2684 code . mkSeqInstr (OR src (RIReg src) iDst)
2687 -- Once we have run out of argument registers, we move to the
2690 get_arg ([], offset) arg
2691 = getRegister arg `thenNat` \ register ->
2692 getNewRegNCG (registerRep register)
2695 code = registerCode register tmp
2696 src = registerName register tmp
2697 pk = registerRep register
2698 sz = primRepToSize pk
2700 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2702 #endif {- alpha_TARGET_ARCH -}
2704 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2706 #if i386_TARGET_ARCH
2708 genCCall fn cconv ret_rep args
2710 (reverse args) `thenNat` \ sizes_n_codes ->
2711 getDeltaNat `thenNat` \ delta ->
2712 let (sizes, push_codes) = unzip sizes_n_codes
2713 tot_arg_size = sum sizes
2715 -- deal with static vs dynamic call targets
2718 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2720 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2721 ASSERT(case dyn_rep of { L -> True; _ -> False})
2722 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2724 `thenNat` \ callinsns ->
2725 let push_code = concatOL push_codes
2726 call = callinsns `appOL`
2728 -- Deallocate parameters after call for ccall;
2729 -- but not for stdcall (callee does it)
2730 (if cconv == StdCallConv then [] else
2731 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2733 [DELTA (delta + tot_arg_size)]
2736 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2737 returnNat (push_code `appOL` call)
2740 -- function names that begin with '.' are assumed to be special
2741 -- internally generated names like '.mul,' which don't get an
2742 -- underscore prefix
2743 -- ToDo:needed (WDP 96/03) ???
2744 fn_u = _UNPK_ (unLeft fn)
2747 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2748 | otherwise -- General case
2749 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2751 stdcallsize tot_arg_size
2752 | cconv == StdCallConv = '@':show tot_arg_size
2760 push_arg :: StixExpr{-current argument-}
2761 -> NatM (Int, InstrBlock) -- argsz, code
2764 | is64BitRep arg_rep
2765 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2766 getDeltaNat `thenNat` \ delta ->
2767 setDeltaNat (delta - 8) `thenNat` \ _ ->
2768 let r_lo = VirtualRegI vr_lo
2769 r_hi = getHiVRegFromLo r_lo
2772 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2773 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2776 = get_op arg `thenNat` \ (code, reg, sz) ->
2777 getDeltaNat `thenNat` \ delta ->
2778 arg_size sz `bind` \ size ->
2779 setDeltaNat (delta-size) `thenNat` \ _ ->
2780 if (case sz of DF -> True; F -> True; _ -> False)
2781 then returnNat (size,
2783 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2785 GST sz reg (AddrBaseIndex (Just esp)
2789 else returnNat (size,
2791 PUSH L (OpReg reg) `snocOL`
2795 arg_rep = repOfStixExpr arg
2800 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2803 = getRegister op `thenNat` \ register ->
2804 getNewRegNCG (registerRep register)
2807 code = registerCode register tmp
2808 reg = registerName register tmp
2809 pk = registerRep register
2810 sz = primRepToSize pk
2812 returnNat (code, reg, sz)
2814 #endif {- i386_TARGET_ARCH -}
2816 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2818 #if sparc_TARGET_ARCH
2820 The SPARC calling convention is an absolute
2821 nightmare. The first 6x32 bits of arguments are mapped into
2822 %o0 through %o5, and the remaining arguments are dumped to the
2823 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2825 If we have to put args on the stack, move %o6==%sp down by
2826 the number of words to go on the stack, to ensure there's enough space.
2828 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2829 16 words above the stack pointer is a word for the address of
2830 a structure return value. I use this as a temporary location
2831 for moving values from float to int regs. Certainly it isn't
2832 safe to put anything in the 16 words starting at %sp, since
2833 this area can get trashed at any time due to window overflows
2834 caused by signal handlers.
2836 A final complication (if the above isn't enough) is that
2837 we can't blithely calculate the arguments one by one into
2838 %o0 .. %o5. Consider the following nested calls:
2842 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2843 the inner call will itself use %o0, which trashes the value put there
2844 in preparation for the outer call. Upshot: we need to calculate the
2845 args into temporary regs, and move those to arg regs or onto the
2846 stack only immediately prior to the call proper. Sigh.
2849 genCCall fn cconv kind args
2850 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2852 (argcodes, vregss) = unzip argcode_and_vregs
2853 n_argRegs = length allArgRegs
2854 n_argRegs_used = min (length vregs) n_argRegs
2855 vregs = concat vregss
2857 -- deal with static vs dynamic call targets
2860 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2862 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2863 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2865 `thenNat` \ callinsns ->
2867 argcode = concatOL argcodes
2868 (move_sp_down, move_sp_up)
2869 = let nn = length vregs - n_argRegs
2870 + 1 -- (for the road)
2873 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2875 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2877 returnNat (argcode `appOL`
2878 move_sp_down `appOL`
2879 transfer_code `appOL`
2884 -- function names that begin with '.' are assumed to be special
2885 -- internally generated names like '.mul,' which don't get an
2886 -- underscore prefix
2887 -- ToDo:needed (WDP 96/03) ???
2888 fn_static = unLeft fn
2889 fn__2 = case (_HEAD_ fn_static) of
2890 '.' -> ImmLit (ptext fn_static)
2891 _ -> ImmLab False (ptext fn_static)
2893 -- move args from the integer vregs into which they have been
2894 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2895 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2897 move_final [] _ offset -- all args done
2900 move_final (v:vs) [] offset -- out of aregs; move to stack
2901 = ST W v (spRel offset)
2902 : move_final vs [] (offset+1)
2904 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2905 = OR False g0 (RIReg v) a
2906 : move_final vs az offset
2908 -- generate code to calculate an argument, and move it into one
2909 -- or two integer vregs.
2910 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2911 arg_to_int_vregs arg
2912 | is64BitRep (repOfStixExpr arg)
2913 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2914 let r_lo = VirtualRegI vr_lo
2915 r_hi = getHiVRegFromLo r_lo
2916 in returnNat (code, [r_hi, r_lo])
2918 = getRegister arg `thenNat` \ register ->
2919 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2920 let code = registerCode register tmp
2921 src = registerName register tmp
2922 pk = registerRep register
2924 -- the value is in src. Get it into 1 or 2 int vregs.
2927 getNewRegNCG WordRep `thenNat` \ v1 ->
2928 getNewRegNCG WordRep `thenNat` \ v2 ->
2931 FMOV DF src f0 `snocOL`
2932 ST F f0 (spRel 16) `snocOL`
2933 LD W (spRel 16) v1 `snocOL`
2934 ST F (fPair f0) (spRel 16) `snocOL`
2940 getNewRegNCG WordRep `thenNat` \ v1 ->
2943 ST F src (spRel 16) `snocOL`
2949 getNewRegNCG WordRep `thenNat` \ v1 ->
2951 code `snocOL` OR False g0 (RIReg src) v1
2955 #endif {- sparc_TARGET_ARCH -}
2957 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2960 %************************************************************************
2962 \subsection{Support bits}
2964 %************************************************************************
2966 %************************************************************************
2968 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2970 %************************************************************************
2972 Turn those condition codes into integers now (when they appear on
2973 the right hand side of an assignment).
2975 (If applicable) Do not fill the delay slots here; you will confuse the
2979 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2981 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2983 #if alpha_TARGET_ARCH
2984 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2985 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2986 #endif {- alpha_TARGET_ARCH -}
2988 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2990 #if i386_TARGET_ARCH
2993 = condIntCode cond x y `thenNat` \ condition ->
2994 getNewRegNCG IntRep `thenNat` \ tmp ->
2996 code = condCode condition
2997 cond = condName condition
2998 code__2 dst = code `appOL` toOL [
2999 SETCC cond (OpReg tmp),
3000 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3001 MOV L (OpReg tmp) (OpReg dst)]
3003 returnNat (Any IntRep code__2)
3006 = getNatLabelNCG `thenNat` \ lbl1 ->
3007 getNatLabelNCG `thenNat` \ lbl2 ->
3008 condFltCode cond x y `thenNat` \ condition ->
3010 code = condCode condition
3011 cond = condName condition
3012 code__2 dst = code `appOL` toOL [
3014 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3017 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3020 returnNat (Any IntRep code__2)
3022 #endif {- i386_TARGET_ARCH -}
3024 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3026 #if sparc_TARGET_ARCH
3028 condIntReg EQQ x (StInt 0)
3029 = getRegister x `thenNat` \ register ->
3030 getNewRegNCG IntRep `thenNat` \ tmp ->
3032 code = registerCode register tmp
3033 src = registerName register tmp
3034 code__2 dst = code `appOL` toOL [
3035 SUB False True g0 (RIReg src) g0,
3036 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3038 returnNat (Any IntRep code__2)
3041 = getRegister x `thenNat` \ register1 ->
3042 getRegister y `thenNat` \ register2 ->
3043 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3044 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3046 code1 = registerCode register1 tmp1
3047 src1 = registerName register1 tmp1
3048 code2 = registerCode register2 tmp2
3049 src2 = registerName register2 tmp2
3050 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3051 XOR False src1 (RIReg src2) dst,
3052 SUB False True g0 (RIReg dst) g0,
3053 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3055 returnNat (Any IntRep code__2)
3057 condIntReg NE x (StInt 0)
3058 = getRegister x `thenNat` \ register ->
3059 getNewRegNCG IntRep `thenNat` \ tmp ->
3061 code = registerCode register tmp
3062 src = registerName register tmp
3063 code__2 dst = code `appOL` toOL [
3064 SUB False True g0 (RIReg src) g0,
3065 ADD True False g0 (RIImm (ImmInt 0)) dst]
3067 returnNat (Any IntRep code__2)
3070 = getRegister x `thenNat` \ register1 ->
3071 getRegister y `thenNat` \ register2 ->
3072 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3073 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3075 code1 = registerCode register1 tmp1
3076 src1 = registerName register1 tmp1
3077 code2 = registerCode register2 tmp2
3078 src2 = registerName register2 tmp2
3079 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3080 XOR False src1 (RIReg src2) dst,
3081 SUB False True g0 (RIReg dst) g0,
3082 ADD True False g0 (RIImm (ImmInt 0)) dst]
3084 returnNat (Any IntRep code__2)
3087 = getNatLabelNCG `thenNat` \ lbl1 ->
3088 getNatLabelNCG `thenNat` \ lbl2 ->
3089 condIntCode cond x y `thenNat` \ condition ->
3091 code = condCode condition
3092 cond = condName condition
3093 code__2 dst = code `appOL` toOL [
3094 BI cond False (ImmCLbl lbl1), NOP,
3095 OR False g0 (RIImm (ImmInt 0)) dst,
3096 BI ALWAYS False (ImmCLbl lbl2), NOP,
3098 OR False g0 (RIImm (ImmInt 1)) dst,
3101 returnNat (Any IntRep code__2)
3104 = getNatLabelNCG `thenNat` \ lbl1 ->
3105 getNatLabelNCG `thenNat` \ lbl2 ->
3106 condFltCode cond x y `thenNat` \ condition ->
3108 code = condCode condition
3109 cond = condName condition
3110 code__2 dst = code `appOL` toOL [
3112 BF cond False (ImmCLbl lbl1), NOP,
3113 OR False g0 (RIImm (ImmInt 0)) dst,
3114 BI ALWAYS False (ImmCLbl lbl2), NOP,
3116 OR False g0 (RIImm (ImmInt 1)) dst,
3119 returnNat (Any IntRep code__2)
3121 #endif {- sparc_TARGET_ARCH -}
3123 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3126 %************************************************************************
3128 \subsubsection{@trivial*Code@: deal with trivial instructions}
3130 %************************************************************************
3132 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3133 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3134 for constants on the right hand side, because that's where the generic
3135 optimizer will have put them.
3137 Similarly, for unary instructions, we don't have to worry about
3138 matching an StInt as the argument, because genericOpt will already
3139 have handled the constant-folding.
3143 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3144 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3145 -> Maybe (Operand -> Operand -> Instr)
3146 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3148 -> StixExpr -> StixExpr -- the two arguments
3153 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3154 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3155 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3157 -> StixExpr -> StixExpr -- the two arguments
3161 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3162 ,IF_ARCH_i386 ((Operand -> Instr)
3163 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3165 -> StixExpr -- the one argument
3170 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3171 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3172 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3174 -> StixExpr -- the one argument
3177 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3179 #if alpha_TARGET_ARCH
3181 trivialCode instr x (StInt y)
3183 = getRegister x `thenNat` \ register ->
3184 getNewRegNCG IntRep `thenNat` \ tmp ->
3186 code = registerCode register tmp
3187 src1 = registerName register tmp
3188 src2 = ImmInt (fromInteger y)
3189 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3191 returnNat (Any IntRep code__2)
3193 trivialCode instr x y
3194 = getRegister x `thenNat` \ register1 ->
3195 getRegister y `thenNat` \ register2 ->
3196 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3197 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3199 code1 = registerCode register1 tmp1 []
3200 src1 = registerName register1 tmp1
3201 code2 = registerCode register2 tmp2 []
3202 src2 = registerName register2 tmp2
3203 code__2 dst = asmSeqThen [code1, code2] .
3204 mkSeqInstr (instr src1 (RIReg src2) dst)
3206 returnNat (Any IntRep code__2)
3209 trivialUCode instr x
3210 = getRegister x `thenNat` \ register ->
3211 getNewRegNCG IntRep `thenNat` \ tmp ->
3213 code = registerCode register tmp
3214 src = registerName register tmp
3215 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3217 returnNat (Any IntRep code__2)
3220 trivialFCode _ instr x y
3221 = getRegister x `thenNat` \ register1 ->
3222 getRegister y `thenNat` \ register2 ->
3223 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3224 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3226 code1 = registerCode register1 tmp1
3227 src1 = registerName register1 tmp1
3229 code2 = registerCode register2 tmp2
3230 src2 = registerName register2 tmp2
3232 code__2 dst = asmSeqThen [code1 [], code2 []] .
3233 mkSeqInstr (instr src1 src2 dst)
3235 returnNat (Any DoubleRep code__2)
3237 trivialUFCode _ instr x
3238 = getRegister x `thenNat` \ register ->
3239 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3241 code = registerCode register tmp
3242 src = registerName register tmp
3243 code__2 dst = code . mkSeqInstr (instr src dst)
3245 returnNat (Any DoubleRep code__2)
3247 #endif {- alpha_TARGET_ARCH -}
3249 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3251 #if i386_TARGET_ARCH
3253 The Rules of the Game are:
3255 * You cannot assume anything about the destination register dst;
3256 it may be anything, including a fixed reg.
3258 * You may compute an operand into a fixed reg, but you may not
3259 subsequently change the contents of that fixed reg. If you
3260 want to do so, first copy the value either to a temporary
3261 or into dst. You are free to modify dst even if it happens
3262 to be a fixed reg -- that's not your problem.
3264 * You cannot assume that a fixed reg will stay live over an
3265 arbitrary computation. The same applies to the dst reg.
3267 * Temporary regs obtained from getNewRegNCG are distinct from
3268 each other and from all other regs, and stay live over
3269 arbitrary computations.
3273 trivialCode instr maybe_revinstr a b
3276 = getRegister a `thenNat` \ rega ->
3279 then registerCode rega dst `bind` \ code_a ->
3281 instr (OpImm imm_b) (OpReg dst)
3282 else registerCodeF rega `bind` \ code_a ->
3283 registerNameF rega `bind` \ r_a ->
3285 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3286 instr (OpImm imm_b) (OpReg dst)
3288 returnNat (Any IntRep mkcode)
3291 = getRegister b `thenNat` \ regb ->
3292 getNewRegNCG IntRep `thenNat` \ tmp ->
3293 let revinstr_avail = maybeToBool maybe_revinstr
3294 revinstr = case maybe_revinstr of Just ri -> ri
3298 then registerCode regb dst `bind` \ code_b ->
3300 revinstr (OpImm imm_a) (OpReg dst)
3301 else registerCodeF regb `bind` \ code_b ->
3302 registerNameF regb `bind` \ r_b ->
3304 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3305 revinstr (OpImm imm_a) (OpReg dst)
3309 then registerCode regb tmp `bind` \ code_b ->
3311 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3312 instr (OpReg tmp) (OpReg dst)
3313 else registerCodeF regb `bind` \ code_b ->
3314 registerNameF regb `bind` \ r_b ->
3316 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3317 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3318 instr (OpReg tmp) (OpReg dst)
3320 returnNat (Any IntRep mkcode)
3323 = getRegister a `thenNat` \ rega ->
3324 getRegister b `thenNat` \ regb ->
3325 getNewRegNCG IntRep `thenNat` \ tmp ->
3327 = case (isAny rega, isAny regb) of
3329 -> registerCode regb tmp `bind` \ code_b ->
3330 registerCode rega dst `bind` \ code_a ->
3333 instr (OpReg tmp) (OpReg dst)
3335 -> registerCode rega tmp `bind` \ code_a ->
3336 registerCodeF regb `bind` \ code_b ->
3337 registerNameF regb `bind` \ r_b ->
3340 instr (OpReg r_b) (OpReg tmp) `snocOL`
3341 MOV L (OpReg tmp) (OpReg dst)
3343 -> registerCode regb tmp `bind` \ code_b ->
3344 registerCodeF rega `bind` \ code_a ->
3345 registerNameF rega `bind` \ r_a ->
3348 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3349 instr (OpReg tmp) (OpReg dst)
3351 -> registerCodeF rega `bind` \ code_a ->
3352 registerNameF rega `bind` \ r_a ->
3353 registerCodeF regb `bind` \ code_b ->
3354 registerNameF regb `bind` \ r_b ->
3356 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3358 instr (OpReg r_b) (OpReg tmp) `snocOL`
3359 MOV L (OpReg tmp) (OpReg dst)
3361 returnNat (Any IntRep mkcode)
3364 maybe_imm_a = maybeImm a
3365 is_imm_a = maybeToBool maybe_imm_a
3366 imm_a = case maybe_imm_a of Just imm -> imm
3368 maybe_imm_b = maybeImm b
3369 is_imm_b = maybeToBool maybe_imm_b
3370 imm_b = case maybe_imm_b of Just imm -> imm
3374 trivialUCode instr x
3375 = getRegister x `thenNat` \ register ->
3377 code__2 dst = let code = registerCode register dst
3378 src = registerName register dst
3380 if isFixed register && dst /= src
3381 then toOL [MOV L (OpReg src) (OpReg dst),
3383 else unitOL (instr (OpReg src))
3385 returnNat (Any IntRep code__2)
3388 trivialFCode pk instr x y
3389 = getRegister x `thenNat` \ register1 ->
3390 getRegister y `thenNat` \ register2 ->
3391 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3392 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3394 code1 = registerCode register1 tmp1
3395 src1 = registerName register1 tmp1
3397 code2 = registerCode register2 tmp2
3398 src2 = registerName register2 tmp2
3401 -- treat the common case specially: both operands in
3403 | isAny register1 && isAny register2
3406 instr (primRepToSize pk) src1 src2 dst
3408 -- be paranoid (and inefficient)
3410 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3412 instr (primRepToSize pk) tmp1 src2 dst
3414 returnNat (Any pk code__2)
3418 trivialUFCode pk instr x
3419 = getRegister x `thenNat` \ register ->
3420 getNewRegNCG pk `thenNat` \ tmp ->
3422 code = registerCode register tmp
3423 src = registerName register tmp
3424 code__2 dst = code `snocOL` instr src dst
3426 returnNat (Any pk code__2)
3428 #endif {- i386_TARGET_ARCH -}
3430 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3432 #if sparc_TARGET_ARCH
3434 trivialCode instr x (StInt y)
3436 = getRegister x `thenNat` \ register ->
3437 getNewRegNCG IntRep `thenNat` \ tmp ->
3439 code = registerCode register tmp
3440 src1 = registerName register tmp
3441 src2 = ImmInt (fromInteger y)
3442 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3444 returnNat (Any IntRep code__2)
3446 trivialCode instr x y
3447 = getRegister x `thenNat` \ register1 ->
3448 getRegister y `thenNat` \ register2 ->
3449 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3450 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3452 code1 = registerCode register1 tmp1
3453 src1 = registerName register1 tmp1
3454 code2 = registerCode register2 tmp2
3455 src2 = registerName register2 tmp2
3456 code__2 dst = code1 `appOL` code2 `snocOL`
3457 instr src1 (RIReg src2) dst
3459 returnNat (Any IntRep code__2)
3462 trivialFCode pk instr x y
3463 = getRegister x `thenNat` \ register1 ->
3464 getRegister y `thenNat` \ register2 ->
3465 getNewRegNCG (registerRep register1)
3467 getNewRegNCG (registerRep register2)
3469 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3471 promote x = FxTOy F DF x tmp
3473 pk1 = registerRep register1
3474 code1 = registerCode register1 tmp1
3475 src1 = registerName register1 tmp1
3477 pk2 = registerRep register2
3478 code2 = registerCode register2 tmp2
3479 src2 = registerName register2 tmp2
3483 code1 `appOL` code2 `snocOL`
3484 instr (primRepToSize pk) src1 src2 dst
3485 else if pk1 == FloatRep then
3486 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3487 instr DF tmp src2 dst
3489 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3490 instr DF src1 tmp dst
3492 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3495 trivialUCode instr x
3496 = getRegister x `thenNat` \ register ->
3497 getNewRegNCG IntRep `thenNat` \ tmp ->
3499 code = registerCode register tmp
3500 src = registerName register tmp
3501 code__2 dst = code `snocOL` instr (RIReg src) dst
3503 returnNat (Any IntRep code__2)
3506 trivialUFCode pk instr x
3507 = getRegister x `thenNat` \ register ->
3508 getNewRegNCG pk `thenNat` \ tmp ->
3510 code = registerCode register tmp
3511 src = registerName register tmp
3512 code__2 dst = code `snocOL` instr src dst
3514 returnNat (Any pk code__2)
3516 #endif {- sparc_TARGET_ARCH -}
3518 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3521 %************************************************************************
3523 \subsubsection{Coercing to/from integer/floating-point...}
3525 %************************************************************************
3527 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3528 conversions. We have to store temporaries in memory to move
3529 between the integer and the floating point register sets.
3531 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3532 pretend, on sparc at least, that double and float regs are seperate
3533 kinds, so the value has to be computed into one kind before being
3534 explicitly "converted" to live in the other kind.
3537 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3538 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3540 coerceDbl2Flt :: StixExpr -> NatM Register
3541 coerceFlt2Dbl :: StixExpr -> NatM Register
3545 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3547 #if alpha_TARGET_ARCH
3550 = getRegister x `thenNat` \ register ->
3551 getNewRegNCG IntRep `thenNat` \ reg ->
3553 code = registerCode register reg
3554 src = registerName register reg
3556 code__2 dst = code . mkSeqInstrs [
3558 LD TF dst (spRel 0),
3561 returnNat (Any DoubleRep code__2)
3565 = getRegister x `thenNat` \ register ->
3566 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3568 code = registerCode register tmp
3569 src = registerName register tmp
3571 code__2 dst = code . mkSeqInstrs [
3573 ST TF tmp (spRel 0),
3576 returnNat (Any IntRep code__2)
3578 #endif {- alpha_TARGET_ARCH -}
3580 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3582 #if i386_TARGET_ARCH
3585 = getRegister x `thenNat` \ register ->
3586 getNewRegNCG IntRep `thenNat` \ reg ->
3588 code = registerCode register reg
3589 src = registerName register reg
3590 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3591 code__2 dst = code `snocOL` opc src dst
3593 returnNat (Any pk code__2)
3596 coerceFP2Int fprep x
3597 = getRegister x `thenNat` \ register ->
3598 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3600 code = registerCode register tmp
3601 src = registerName register tmp
3602 pk = registerRep register
3604 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3605 code__2 dst = code `snocOL` opc src dst
3607 returnNat (Any IntRep code__2)
3610 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3611 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3613 #endif {- i386_TARGET_ARCH -}
3615 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3617 #if sparc_TARGET_ARCH
3620 = getRegister x `thenNat` \ register ->
3621 getNewRegNCG IntRep `thenNat` \ reg ->
3623 code = registerCode register reg
3624 src = registerName register reg
3626 code__2 dst = code `appOL` toOL [
3627 ST W src (spRel (-2)),
3628 LD W (spRel (-2)) dst,
3629 FxTOy W (primRepToSize pk) dst dst]
3631 returnNat (Any pk code__2)
3634 coerceFP2Int fprep x
3635 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3636 getRegister x `thenNat` \ register ->
3637 getNewRegNCG fprep `thenNat` \ reg ->
3638 getNewRegNCG FloatRep `thenNat` \ tmp ->
3640 code = registerCode register reg
3641 src = registerName register reg
3642 code__2 dst = code `appOL` toOL [
3643 FxTOy (primRepToSize fprep) W src tmp,
3644 ST W tmp (spRel (-2)),
3645 LD W (spRel (-2)) dst]
3647 returnNat (Any IntRep code__2)
3651 = getRegister x `thenNat` \ register ->
3652 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3653 let code = registerCode register tmp
3654 src = registerName register tmp
3656 returnNat (Any FloatRep
3657 (\dst -> code `snocOL` FxTOy DF F src dst))
3661 = getRegister x `thenNat` \ register ->
3662 getNewRegNCG FloatRep `thenNat` \ tmp ->
3663 let code = registerCode register tmp
3664 src = registerName register tmp
3666 returnNat (Any DoubleRep
3667 (\dst -> code `snocOL` FxTOy F DF src dst))
3669 #endif {- sparc_TARGET_ARCH -}
3671 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -