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
2755 -- floats are always promoted to doubles when passed to a ccall
2757 promote_size sz = sz
2764 push_arg :: StixExpr{-current argument-}
2765 -> NatM (Int, InstrBlock) -- argsz, code
2768 | is64BitRep arg_rep
2769 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2770 getDeltaNat `thenNat` \ delta ->
2771 setDeltaNat (delta - 8) `thenNat` \ _ ->
2772 let r_lo = VirtualRegI vr_lo
2773 r_hi = getHiVRegFromLo r_lo
2776 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2777 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2780 = get_op arg `thenNat` \ (code, reg, sz) ->
2781 getDeltaNat `thenNat` \ delta ->
2783 real_sz = promote_size sz
2784 size = arg_size real_sz
2786 setDeltaNat (delta-size) `thenNat` \ _ ->
2787 if (case real_sz of DF -> True; _ -> False)
2788 then returnNat (size,
2790 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2792 GST DF reg (AddrBaseIndex (Just esp)
2796 else returnNat (size,
2798 PUSH L (OpReg reg) `snocOL`
2802 arg_rep = repOfStixExpr arg
2807 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2810 = getRegister op `thenNat` \ register ->
2811 getNewRegNCG (registerRep register)
2814 code = registerCode register tmp
2815 reg = registerName register tmp
2816 pk = registerRep register
2817 sz = primRepToSize pk
2819 returnNat (code, reg, sz)
2821 #endif {- i386_TARGET_ARCH -}
2823 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2825 #if sparc_TARGET_ARCH
2827 The SPARC calling convention is an absolute
2828 nightmare. The first 6x32 bits of arguments are mapped into
2829 %o0 through %o5, and the remaining arguments are dumped to the
2830 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2832 If we have to put args on the stack, move %o6==%sp down by
2833 the number of words to go on the stack, to ensure there's enough space.
2835 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2836 16 words above the stack pointer is a word for the address of
2837 a structure return value. I use this as a temporary location
2838 for moving values from float to int regs. Certainly it isn't
2839 safe to put anything in the 16 words starting at %sp, since
2840 this area can get trashed at any time due to window overflows
2841 caused by signal handlers.
2843 A final complication (if the above isn't enough) is that
2844 we can't blithely calculate the arguments one by one into
2845 %o0 .. %o5. Consider the following nested calls:
2849 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2850 the inner call will itself use %o0, which trashes the value put there
2851 in preparation for the outer call. Upshot: we need to calculate the
2852 args into temporary regs, and move those to arg regs or onto the
2853 stack only immediately prior to the call proper. Sigh.
2856 genCCall fn cconv kind args
2857 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2859 (argcodes, vregss) = unzip argcode_and_vregs
2860 n_argRegs = length allArgRegs
2861 n_argRegs_used = min (length vregs) n_argRegs
2862 vregs = concat vregss
2864 -- deal with static vs dynamic call targets
2867 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2869 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2870 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2872 `thenNat` \ callinsns ->
2874 argcode = concatOL argcodes
2875 (move_sp_down, move_sp_up)
2876 = let nn = length vregs - n_argRegs
2877 + 1 -- (for the road)
2880 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2882 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2884 returnNat (argcode `appOL`
2885 move_sp_down `appOL`
2886 transfer_code `appOL`
2891 -- function names that begin with '.' are assumed to be special
2892 -- internally generated names like '.mul,' which don't get an
2893 -- underscore prefix
2894 -- ToDo:needed (WDP 96/03) ???
2895 fn_static = unLeft fn
2896 fn__2 = case (_HEAD_ fn_static) of
2897 '.' -> ImmLit (ptext fn_static)
2898 _ -> ImmLab False (ptext fn_static)
2900 -- move args from the integer vregs into which they have been
2901 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2902 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2904 move_final [] _ offset -- all args done
2907 move_final (v:vs) [] offset -- out of aregs; move to stack
2908 = ST W v (spRel offset)
2909 : move_final vs [] (offset+1)
2911 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2912 = OR False g0 (RIReg v) a
2913 : move_final vs az offset
2915 -- generate code to calculate an argument, and move it into one
2916 -- or two integer vregs.
2917 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2918 arg_to_int_vregs arg
2919 | is64BitRep (repOfStixExpr arg)
2920 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2921 let r_lo = VirtualRegI vr_lo
2922 r_hi = getHiVRegFromLo r_lo
2923 in returnNat (code, [r_hi, r_lo])
2925 = getRegister arg `thenNat` \ register ->
2926 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2927 let code = registerCode register tmp
2928 src = registerName register tmp
2929 pk = registerRep register
2931 -- the value is in src. Get it into 1 or 2 int vregs.
2934 getNewRegNCG WordRep `thenNat` \ v1 ->
2935 getNewRegNCG WordRep `thenNat` \ v2 ->
2938 FMOV DF src f0 `snocOL`
2939 ST F f0 (spRel 16) `snocOL`
2940 LD W (spRel 16) v1 `snocOL`
2941 ST F (fPair f0) (spRel 16) `snocOL`
2947 getNewRegNCG WordRep `thenNat` \ v1 ->
2950 ST F src (spRel 16) `snocOL`
2956 getNewRegNCG WordRep `thenNat` \ v1 ->
2958 code `snocOL` OR False g0 (RIReg src) v1
2962 #endif {- sparc_TARGET_ARCH -}
2964 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2967 %************************************************************************
2969 \subsection{Support bits}
2971 %************************************************************************
2973 %************************************************************************
2975 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2977 %************************************************************************
2979 Turn those condition codes into integers now (when they appear on
2980 the right hand side of an assignment).
2982 (If applicable) Do not fill the delay slots here; you will confuse the
2986 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2988 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2990 #if alpha_TARGET_ARCH
2991 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2992 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2993 #endif {- alpha_TARGET_ARCH -}
2995 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2997 #if i386_TARGET_ARCH
3000 = condIntCode cond x y `thenNat` \ condition ->
3001 getNewRegNCG IntRep `thenNat` \ tmp ->
3003 code = condCode condition
3004 cond = condName condition
3005 code__2 dst = code `appOL` toOL [
3006 SETCC cond (OpReg tmp),
3007 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3008 MOV L (OpReg tmp) (OpReg dst)]
3010 returnNat (Any IntRep code__2)
3013 = getNatLabelNCG `thenNat` \ lbl1 ->
3014 getNatLabelNCG `thenNat` \ lbl2 ->
3015 condFltCode cond x y `thenNat` \ condition ->
3017 code = condCode condition
3018 cond = condName condition
3019 code__2 dst = code `appOL` toOL [
3021 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3024 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3027 returnNat (Any IntRep code__2)
3029 #endif {- i386_TARGET_ARCH -}
3031 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3033 #if sparc_TARGET_ARCH
3035 condIntReg EQQ x (StInt 0)
3036 = getRegister x `thenNat` \ register ->
3037 getNewRegNCG IntRep `thenNat` \ tmp ->
3039 code = registerCode register tmp
3040 src = registerName register tmp
3041 code__2 dst = code `appOL` toOL [
3042 SUB False True g0 (RIReg src) g0,
3043 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3045 returnNat (Any IntRep code__2)
3048 = getRegister x `thenNat` \ register1 ->
3049 getRegister y `thenNat` \ register2 ->
3050 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3051 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3053 code1 = registerCode register1 tmp1
3054 src1 = registerName register1 tmp1
3055 code2 = registerCode register2 tmp2
3056 src2 = registerName register2 tmp2
3057 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3058 XOR False src1 (RIReg src2) dst,
3059 SUB False True g0 (RIReg dst) g0,
3060 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3062 returnNat (Any IntRep code__2)
3064 condIntReg NE x (StInt 0)
3065 = getRegister x `thenNat` \ register ->
3066 getNewRegNCG IntRep `thenNat` \ tmp ->
3068 code = registerCode register tmp
3069 src = registerName register tmp
3070 code__2 dst = code `appOL` toOL [
3071 SUB False True g0 (RIReg src) g0,
3072 ADD True False g0 (RIImm (ImmInt 0)) dst]
3074 returnNat (Any IntRep code__2)
3077 = getRegister x `thenNat` \ register1 ->
3078 getRegister y `thenNat` \ register2 ->
3079 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3080 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3082 code1 = registerCode register1 tmp1
3083 src1 = registerName register1 tmp1
3084 code2 = registerCode register2 tmp2
3085 src2 = registerName register2 tmp2
3086 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3087 XOR False src1 (RIReg src2) dst,
3088 SUB False True g0 (RIReg dst) g0,
3089 ADD True False g0 (RIImm (ImmInt 0)) dst]
3091 returnNat (Any IntRep code__2)
3094 = getNatLabelNCG `thenNat` \ lbl1 ->
3095 getNatLabelNCG `thenNat` \ lbl2 ->
3096 condIntCode cond x y `thenNat` \ condition ->
3098 code = condCode condition
3099 cond = condName condition
3100 code__2 dst = code `appOL` toOL [
3101 BI cond False (ImmCLbl lbl1), NOP,
3102 OR False g0 (RIImm (ImmInt 0)) dst,
3103 BI ALWAYS False (ImmCLbl lbl2), NOP,
3105 OR False g0 (RIImm (ImmInt 1)) dst,
3108 returnNat (Any IntRep code__2)
3111 = getNatLabelNCG `thenNat` \ lbl1 ->
3112 getNatLabelNCG `thenNat` \ lbl2 ->
3113 condFltCode cond x y `thenNat` \ condition ->
3115 code = condCode condition
3116 cond = condName condition
3117 code__2 dst = code `appOL` toOL [
3119 BF cond False (ImmCLbl lbl1), NOP,
3120 OR False g0 (RIImm (ImmInt 0)) dst,
3121 BI ALWAYS False (ImmCLbl lbl2), NOP,
3123 OR False g0 (RIImm (ImmInt 1)) dst,
3126 returnNat (Any IntRep code__2)
3128 #endif {- sparc_TARGET_ARCH -}
3130 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3133 %************************************************************************
3135 \subsubsection{@trivial*Code@: deal with trivial instructions}
3137 %************************************************************************
3139 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3140 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3141 for constants on the right hand side, because that's where the generic
3142 optimizer will have put them.
3144 Similarly, for unary instructions, we don't have to worry about
3145 matching an StInt as the argument, because genericOpt will already
3146 have handled the constant-folding.
3150 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3151 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3152 -> Maybe (Operand -> Operand -> Instr)
3153 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3155 -> StixExpr -> StixExpr -- the two arguments
3160 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3161 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3162 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3164 -> StixExpr -> StixExpr -- the two arguments
3168 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3169 ,IF_ARCH_i386 ((Operand -> Instr)
3170 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3172 -> StixExpr -- the one argument
3177 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3178 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3179 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3181 -> StixExpr -- the one argument
3184 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3186 #if alpha_TARGET_ARCH
3188 trivialCode instr x (StInt y)
3190 = getRegister x `thenNat` \ register ->
3191 getNewRegNCG IntRep `thenNat` \ tmp ->
3193 code = registerCode register tmp
3194 src1 = registerName register tmp
3195 src2 = ImmInt (fromInteger y)
3196 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3198 returnNat (Any IntRep code__2)
3200 trivialCode instr x y
3201 = getRegister x `thenNat` \ register1 ->
3202 getRegister y `thenNat` \ register2 ->
3203 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3204 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3206 code1 = registerCode register1 tmp1 []
3207 src1 = registerName register1 tmp1
3208 code2 = registerCode register2 tmp2 []
3209 src2 = registerName register2 tmp2
3210 code__2 dst = asmSeqThen [code1, code2] .
3211 mkSeqInstr (instr src1 (RIReg src2) dst)
3213 returnNat (Any IntRep code__2)
3216 trivialUCode instr x
3217 = getRegister x `thenNat` \ register ->
3218 getNewRegNCG IntRep `thenNat` \ tmp ->
3220 code = registerCode register tmp
3221 src = registerName register tmp
3222 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3224 returnNat (Any IntRep code__2)
3227 trivialFCode _ instr x y
3228 = getRegister x `thenNat` \ register1 ->
3229 getRegister y `thenNat` \ register2 ->
3230 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3231 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3233 code1 = registerCode register1 tmp1
3234 src1 = registerName register1 tmp1
3236 code2 = registerCode register2 tmp2
3237 src2 = registerName register2 tmp2
3239 code__2 dst = asmSeqThen [code1 [], code2 []] .
3240 mkSeqInstr (instr src1 src2 dst)
3242 returnNat (Any DoubleRep code__2)
3244 trivialUFCode _ instr x
3245 = getRegister x `thenNat` \ register ->
3246 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3248 code = registerCode register tmp
3249 src = registerName register tmp
3250 code__2 dst = code . mkSeqInstr (instr src dst)
3252 returnNat (Any DoubleRep code__2)
3254 #endif {- alpha_TARGET_ARCH -}
3256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3258 #if i386_TARGET_ARCH
3260 The Rules of the Game are:
3262 * You cannot assume anything about the destination register dst;
3263 it may be anything, including a fixed reg.
3265 * You may compute an operand into a fixed reg, but you may not
3266 subsequently change the contents of that fixed reg. If you
3267 want to do so, first copy the value either to a temporary
3268 or into dst. You are free to modify dst even if it happens
3269 to be a fixed reg -- that's not your problem.
3271 * You cannot assume that a fixed reg will stay live over an
3272 arbitrary computation. The same applies to the dst reg.
3274 * Temporary regs obtained from getNewRegNCG are distinct from
3275 each other and from all other regs, and stay live over
3276 arbitrary computations.
3280 trivialCode instr maybe_revinstr a b
3283 = getRegister a `thenNat` \ rega ->
3286 then registerCode rega dst `bind` \ code_a ->
3288 instr (OpImm imm_b) (OpReg dst)
3289 else registerCodeF rega `bind` \ code_a ->
3290 registerNameF rega `bind` \ r_a ->
3292 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3293 instr (OpImm imm_b) (OpReg dst)
3295 returnNat (Any IntRep mkcode)
3298 = getRegister b `thenNat` \ regb ->
3299 getNewRegNCG IntRep `thenNat` \ tmp ->
3300 let revinstr_avail = maybeToBool maybe_revinstr
3301 revinstr = case maybe_revinstr of Just ri -> ri
3305 then registerCode regb dst `bind` \ code_b ->
3307 revinstr (OpImm imm_a) (OpReg dst)
3308 else registerCodeF regb `bind` \ code_b ->
3309 registerNameF regb `bind` \ r_b ->
3311 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3312 revinstr (OpImm imm_a) (OpReg dst)
3316 then registerCode regb tmp `bind` \ code_b ->
3318 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3319 instr (OpReg tmp) (OpReg dst)
3320 else registerCodeF regb `bind` \ code_b ->
3321 registerNameF regb `bind` \ r_b ->
3323 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3324 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3325 instr (OpReg tmp) (OpReg dst)
3327 returnNat (Any IntRep mkcode)
3330 = getRegister a `thenNat` \ rega ->
3331 getRegister b `thenNat` \ regb ->
3332 getNewRegNCG IntRep `thenNat` \ tmp ->
3334 = case (isAny rega, isAny regb) of
3336 -> registerCode regb tmp `bind` \ code_b ->
3337 registerCode rega dst `bind` \ code_a ->
3340 instr (OpReg tmp) (OpReg dst)
3342 -> registerCode rega tmp `bind` \ code_a ->
3343 registerCodeF regb `bind` \ code_b ->
3344 registerNameF regb `bind` \ r_b ->
3347 instr (OpReg r_b) (OpReg tmp) `snocOL`
3348 MOV L (OpReg tmp) (OpReg dst)
3350 -> registerCode regb tmp `bind` \ code_b ->
3351 registerCodeF rega `bind` \ code_a ->
3352 registerNameF rega `bind` \ r_a ->
3355 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3356 instr (OpReg tmp) (OpReg dst)
3358 -> registerCodeF rega `bind` \ code_a ->
3359 registerNameF rega `bind` \ r_a ->
3360 registerCodeF regb `bind` \ code_b ->
3361 registerNameF regb `bind` \ r_b ->
3363 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3365 instr (OpReg r_b) (OpReg tmp) `snocOL`
3366 MOV L (OpReg tmp) (OpReg dst)
3368 returnNat (Any IntRep mkcode)
3371 maybe_imm_a = maybeImm a
3372 is_imm_a = maybeToBool maybe_imm_a
3373 imm_a = case maybe_imm_a of Just imm -> imm
3375 maybe_imm_b = maybeImm b
3376 is_imm_b = maybeToBool maybe_imm_b
3377 imm_b = case maybe_imm_b of Just imm -> imm
3381 trivialUCode instr x
3382 = getRegister x `thenNat` \ register ->
3384 code__2 dst = let code = registerCode register dst
3385 src = registerName register dst
3387 if isFixed register && dst /= src
3388 then toOL [MOV L (OpReg src) (OpReg dst),
3390 else unitOL (instr (OpReg src))
3392 returnNat (Any IntRep code__2)
3395 trivialFCode pk instr x y
3396 = getRegister x `thenNat` \ register1 ->
3397 getRegister y `thenNat` \ register2 ->
3398 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3399 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3401 code1 = registerCode register1 tmp1
3402 src1 = registerName register1 tmp1
3404 code2 = registerCode register2 tmp2
3405 src2 = registerName register2 tmp2
3408 -- treat the common case specially: both operands in
3410 | isAny register1 && isAny register2
3413 instr (primRepToSize pk) src1 src2 dst
3415 -- be paranoid (and inefficient)
3417 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3419 instr (primRepToSize pk) tmp1 src2 dst
3421 returnNat (Any pk code__2)
3425 trivialUFCode pk instr x
3426 = getRegister x `thenNat` \ register ->
3427 getNewRegNCG pk `thenNat` \ tmp ->
3429 code = registerCode register tmp
3430 src = registerName register tmp
3431 code__2 dst = code `snocOL` instr src dst
3433 returnNat (Any pk code__2)
3435 #endif {- i386_TARGET_ARCH -}
3437 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3439 #if sparc_TARGET_ARCH
3441 trivialCode instr x (StInt y)
3443 = getRegister x `thenNat` \ register ->
3444 getNewRegNCG IntRep `thenNat` \ tmp ->
3446 code = registerCode register tmp
3447 src1 = registerName register tmp
3448 src2 = ImmInt (fromInteger y)
3449 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3451 returnNat (Any IntRep code__2)
3453 trivialCode instr x y
3454 = getRegister x `thenNat` \ register1 ->
3455 getRegister y `thenNat` \ register2 ->
3456 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3457 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3459 code1 = registerCode register1 tmp1
3460 src1 = registerName register1 tmp1
3461 code2 = registerCode register2 tmp2
3462 src2 = registerName register2 tmp2
3463 code__2 dst = code1 `appOL` code2 `snocOL`
3464 instr src1 (RIReg src2) dst
3466 returnNat (Any IntRep code__2)
3469 trivialFCode pk instr x y
3470 = getRegister x `thenNat` \ register1 ->
3471 getRegister y `thenNat` \ register2 ->
3472 getNewRegNCG (registerRep register1)
3474 getNewRegNCG (registerRep register2)
3476 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3478 promote x = FxTOy F DF x tmp
3480 pk1 = registerRep register1
3481 code1 = registerCode register1 tmp1
3482 src1 = registerName register1 tmp1
3484 pk2 = registerRep register2
3485 code2 = registerCode register2 tmp2
3486 src2 = registerName register2 tmp2
3490 code1 `appOL` code2 `snocOL`
3491 instr (primRepToSize pk) src1 src2 dst
3492 else if pk1 == FloatRep then
3493 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3494 instr DF tmp src2 dst
3496 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3497 instr DF src1 tmp dst
3499 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3502 trivialUCode instr x
3503 = getRegister x `thenNat` \ register ->
3504 getNewRegNCG IntRep `thenNat` \ tmp ->
3506 code = registerCode register tmp
3507 src = registerName register tmp
3508 code__2 dst = code `snocOL` instr (RIReg src) dst
3510 returnNat (Any IntRep code__2)
3513 trivialUFCode pk instr x
3514 = getRegister x `thenNat` \ register ->
3515 getNewRegNCG pk `thenNat` \ tmp ->
3517 code = registerCode register tmp
3518 src = registerName register tmp
3519 code__2 dst = code `snocOL` instr src dst
3521 returnNat (Any pk code__2)
3523 #endif {- sparc_TARGET_ARCH -}
3525 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3528 %************************************************************************
3530 \subsubsection{Coercing to/from integer/floating-point...}
3532 %************************************************************************
3534 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3535 conversions. We have to store temporaries in memory to move
3536 between the integer and the floating point register sets.
3538 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3539 pretend, on sparc at least, that double and float regs are seperate
3540 kinds, so the value has to be computed into one kind before being
3541 explicitly "converted" to live in the other kind.
3544 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3545 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3547 coerceDbl2Flt :: StixExpr -> NatM Register
3548 coerceFlt2Dbl :: StixExpr -> NatM Register
3552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3554 #if alpha_TARGET_ARCH
3557 = getRegister x `thenNat` \ register ->
3558 getNewRegNCG IntRep `thenNat` \ reg ->
3560 code = registerCode register reg
3561 src = registerName register reg
3563 code__2 dst = code . mkSeqInstrs [
3565 LD TF dst (spRel 0),
3568 returnNat (Any DoubleRep code__2)
3572 = getRegister x `thenNat` \ register ->
3573 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3575 code = registerCode register tmp
3576 src = registerName register tmp
3578 code__2 dst = code . mkSeqInstrs [
3580 ST TF tmp (spRel 0),
3583 returnNat (Any IntRep code__2)
3585 #endif {- alpha_TARGET_ARCH -}
3587 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3589 #if i386_TARGET_ARCH
3592 = getRegister x `thenNat` \ register ->
3593 getNewRegNCG IntRep `thenNat` \ reg ->
3595 code = registerCode register reg
3596 src = registerName register reg
3597 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3598 code__2 dst = code `snocOL` opc src dst
3600 returnNat (Any pk code__2)
3603 coerceFP2Int fprep x
3604 = getRegister x `thenNat` \ register ->
3605 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3607 code = registerCode register tmp
3608 src = registerName register tmp
3609 pk = registerRep register
3611 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3612 code__2 dst = code `snocOL` opc src dst
3614 returnNat (Any IntRep code__2)
3617 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3618 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3620 #endif {- i386_TARGET_ARCH -}
3622 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3624 #if sparc_TARGET_ARCH
3627 = getRegister x `thenNat` \ register ->
3628 getNewRegNCG IntRep `thenNat` \ reg ->
3630 code = registerCode register reg
3631 src = registerName register reg
3633 code__2 dst = code `appOL` toOL [
3634 ST W src (spRel (-2)),
3635 LD W (spRel (-2)) dst,
3636 FxTOy W (primRepToSize pk) dst dst]
3638 returnNat (Any pk code__2)
3641 coerceFP2Int fprep x
3642 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3643 getRegister x `thenNat` \ register ->
3644 getNewRegNCG fprep `thenNat` \ reg ->
3645 getNewRegNCG FloatRep `thenNat` \ tmp ->
3647 code = registerCode register reg
3648 src = registerName register reg
3649 code__2 dst = code `appOL` toOL [
3650 FxTOy (primRepToSize fprep) W src tmp,
3651 ST W tmp (spRel (-2)),
3652 LD W (spRel (-2)) dst]
3654 returnNat (Any IntRep code__2)
3658 = getRegister x `thenNat` \ register ->
3659 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3660 let code = registerCode register tmp
3661 src = registerName register tmp
3663 returnNat (Any FloatRep
3664 (\dst -> code `snocOL` FxTOy DF F src dst))
3668 = getRegister x `thenNat` \ register ->
3669 getNewRegNCG FloatRep `thenNat` \ tmp ->
3670 let code = registerCode register tmp
3671 src = registerName register tmp
3673 returnNat (Any DoubleRep
3674 (\dst -> code `snocOL` FxTOy F DF src dst))
3676 #endif {- sparc_TARGET_ARCH -}
3678 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -