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, Maybe012(..) )
31 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
32 getPrimRepArrayElemSize )
33 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
34 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
35 DestInfo, hasDestInfo,
36 pprStixExpr, repOfStixExpr,
38 NatM, thenNat, returnNat, mapNat,
39 mapAndUnzipNat, mapAccumLNat,
40 getDeltaNat, setDeltaNat, getUniqueNat,
45 import Outputable ( panic, pprPanic, showSDoc )
46 import qualified Outputable
47 import CmdLineOpts ( opt_Static )
48 import Stix ( pprStixStmt )
51 import IOExts ( trace )
56 @InstrBlock@s are the insn sequences generated by the insn selectors.
57 They are really trees of insns to facilitate fast appending, where a
58 left-to-right traversal (pre-order?) yields the insns in the correct
62 type InstrBlock = OrdList Instr
67 Code extractor for an entire stix tree---stix statement level.
70 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
72 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
73 returnNat (concatOL instrss)
76 stmtToInstrs :: StixStmt -> NatM InstrBlock
77 stmtToInstrs stmt = case stmt of
78 StComment s -> returnNat (unitOL (COMMENT s))
79 StSegment seg -> returnNat (unitOL (SEGMENT seg))
81 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
83 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
86 StLabel lab -> returnNat (unitOL (LABEL lab))
88 StJump dsts arg -> genJump dsts (derefDLL arg)
89 StCondJump lab arg -> genCondJump lab (derefDLL arg)
91 -- A call returning void, ie one done for its side-effects. Note
92 -- that this is the only StVoidable we handle.
93 StVoidable (StCall fn cconv VoidRep args)
94 -> genCCall fn cconv VoidRep (map derefDLL args)
96 StAssignMem pk addr src
97 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
99 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
100 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
101 StAssignReg pk reg src
102 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
103 | ncg_target_is_32bit
104 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
105 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
106 StAssignMachOp lhss mop rhss
107 -> assignMachOp lhss mop rhss
110 -- When falling through on the Alpha, we still have to load pv
111 -- with the address of the next routine, so that it can load gp.
112 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
116 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
117 returnNat (DATA (primRepToSize kind) imms
118 `consOL` concatOL codes)
120 getData :: StixExpr -> NatM (InstrBlock, Imm)
121 getData (StInt i) = returnNat (nilOL, ImmInteger i)
122 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
123 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
124 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
125 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
126 -- the linker can handle simple arithmetic...
127 getData (StIndex rep (StCLbl lbl) (StInt off)) =
129 ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
131 -- Top-level lifted-out string. The segment will already have been set
132 -- (see Stix.liftStrings).
134 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
137 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
140 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
141 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
142 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
144 derefDLL :: StixExpr -> StixExpr
146 | opt_Static -- short out the entire deal if not doing DLLs
153 StCLbl lbl -> if labelDynamic lbl
154 then StInd PtrRep (StCLbl lbl)
156 -- all the rest are boring
157 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
158 StMachOp mop args -> StMachOp mop (map qq args)
159 StInd pk addr -> StInd pk (qq addr)
160 StCall who cc pk args -> StCall who cc pk (map qq args)
166 _ -> pprPanic "derefDLL: unhandled case"
169 assignMachOp :: Maybe012 StixVReg -> MachOp -> [StixExpr]
173 %************************************************************************
175 \subsection{General things for putting together code sequences}
177 %************************************************************************
180 mangleIndexTree :: StixExpr -> StixExpr
182 mangleIndexTree (StIndex pk base (StInt i))
183 = StMachOp MO_Nat_Add [base, off]
185 off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
187 mangleIndexTree (StIndex pk base off)
188 = StMachOp MO_Nat_Add [
191 in if s == 0 then off
192 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
195 shift :: PrimRep -> Int
196 shift rep = case getPrimRepArrayElemSize rep of
201 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
202 (Outputable.int other)
206 maybeImm :: StixExpr -> Maybe Imm
210 maybeImm (StIndex rep (StCLbl l) (StInt off))
211 = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
213 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
214 = Just (ImmInt (fromInteger i))
216 = Just (ImmInteger i)
221 %************************************************************************
223 \subsection{The @Register64@ type}
225 %************************************************************************
227 Simple support for generating 64-bit code (ie, 64 bit values and 64
228 bit assignments) on 32-bit platforms. Unlike the main code generator
229 we merely shoot for generating working code as simply as possible, and
230 pay little attention to code quality. Specifically, there is no
231 attempt to deal cleverly with the fixed-vs-floating register
232 distinction; all values are generated into (pairs of) floating
233 registers, even if this would mean some redundant reg-reg moves as a
234 result. Only one of the VRegUniques is returned, since it will be
235 of the VRegUniqueLo form, and the upper-half VReg can be determined
236 by applying getHiVRegFromLo to it.
240 data ChildCode64 -- a.k.a "Register64"
243 VRegUnique -- unique for the lower 32-bit temporary
244 -- which contains the result; use getHiVRegFromLo to find
245 -- the other VRegUnique.
246 -- Rules of this simplified insn selection game are
247 -- therefore that the returned VRegUnique may be modified
249 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
250 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
251 iselExpr64 :: StixExpr -> NatM ChildCode64
253 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
257 assignMem_I64Code addrTree valueTree
258 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
259 getRegister addrTree `thenNat` \ register_addr ->
260 getNewRegNCG IntRep `thenNat` \ t_addr ->
261 let rlo = VirtualRegI vrlo
262 rhi = getHiVRegFromLo rlo
263 code_addr = registerCode register_addr t_addr
264 reg_addr = registerName register_addr t_addr
265 -- Little-endian store
266 mov_lo = MOV L (OpReg rlo)
267 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
268 mov_hi = MOV L (OpReg rhi)
269 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
271 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
273 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
274 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
276 r_dst_lo = mkVReg u_dst IntRep
277 r_src_lo = VirtualRegI vr_src_lo
278 r_dst_hi = getHiVRegFromLo r_dst_lo
279 r_src_hi = getHiVRegFromLo r_src_lo
280 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
281 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
284 vcode `snocOL` mov_lo `snocOL` mov_hi
287 assignReg_I64Code lvalue valueTree
288 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
293 iselExpr64 (StInd pk addrTree)
295 = getRegister addrTree `thenNat` \ register_addr ->
296 getNewRegNCG IntRep `thenNat` \ t_addr ->
297 getNewRegNCG IntRep `thenNat` \ rlo ->
298 let rhi = getHiVRegFromLo rlo
299 code_addr = registerCode register_addr t_addr
300 reg_addr = registerName register_addr t_addr
301 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
303 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
307 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
311 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
313 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
314 let r_dst_hi = getHiVRegFromLo r_dst_lo
315 r_src_lo = mkVReg vu IntRep
316 r_src_hi = getHiVRegFromLo r_src_lo
317 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
318 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
321 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
324 iselExpr64 (StCall fn cconv kind args)
326 = genCCall fn cconv kind args `thenNat` \ call ->
327 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
328 let r_dst_hi = getHiVRegFromLo r_dst_lo
329 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
330 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
333 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
334 (getVRegUnique r_dst_lo)
338 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
340 #endif {- i386_TARGET_ARCH -}
342 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
344 #if sparc_TARGET_ARCH
346 assignMem_I64Code addrTree valueTree
347 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
348 getRegister addrTree `thenNat` \ register_addr ->
349 getNewRegNCG IntRep `thenNat` \ t_addr ->
350 let rlo = VirtualRegI vrlo
351 rhi = getHiVRegFromLo rlo
352 code_addr = registerCode register_addr t_addr
353 reg_addr = registerName register_addr t_addr
355 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
356 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
358 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
361 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
362 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
364 r_dst_lo = mkVReg u_dst IntRep
365 r_src_lo = VirtualRegI vr_src_lo
366 r_dst_hi = getHiVRegFromLo r_dst_lo
367 r_src_hi = getHiVRegFromLo r_src_lo
368 mov_lo = mkMOV r_src_lo r_dst_lo
369 mov_hi = mkMOV r_src_hi r_dst_hi
370 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
373 vcode `snocOL` mov_hi `snocOL` mov_lo
375 assignReg_I64Code lvalue valueTree
376 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
380 -- Don't delete this -- it's very handy for debugging.
382 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
383 -- = panic "iselExpr64(???)"
385 iselExpr64 (StInd pk addrTree)
387 = getRegister addrTree `thenNat` \ register_addr ->
388 getNewRegNCG IntRep `thenNat` \ t_addr ->
389 getNewRegNCG IntRep `thenNat` \ rlo ->
390 let rhi = getHiVRegFromLo rlo
391 code_addr = registerCode register_addr t_addr
392 reg_addr = registerName register_addr t_addr
393 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
394 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
397 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
401 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
403 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
404 let r_dst_hi = getHiVRegFromLo r_dst_lo
405 r_src_lo = mkVReg vu IntRep
406 r_src_hi = getHiVRegFromLo r_src_lo
407 mov_lo = mkMOV r_src_lo r_dst_lo
408 mov_hi = mkMOV r_src_hi r_dst_hi
409 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
412 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
415 iselExpr64 (StCall fn cconv kind args)
417 = genCCall fn cconv kind args `thenNat` \ call ->
418 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
419 let r_dst_hi = getHiVRegFromLo r_dst_lo
420 mov_lo = mkMOV o0 r_dst_lo
421 mov_hi = mkMOV o1 r_dst_hi
422 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
425 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
426 (getVRegUnique r_dst_lo)
430 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
432 #endif {- sparc_TARGET_ARCH -}
434 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
438 %************************************************************************
440 \subsection{The @Register@ type}
442 %************************************************************************
444 @Register@s passed up the tree. If the stix code forces the register
445 to live in a pre-decided machine register, it comes out as @Fixed@;
446 otherwise, it comes out as @Any@, and the parent can decide which
447 register to put it in.
451 = Fixed PrimRep Reg InstrBlock
452 | Any PrimRep (Reg -> InstrBlock)
454 registerCode :: Register -> Reg -> InstrBlock
455 registerCode (Fixed _ _ code) reg = code
456 registerCode (Any _ code) reg = code reg
458 registerCodeF (Fixed _ _ code) = code
459 registerCodeF (Any _ _) = panic "registerCodeF"
461 registerCodeA (Any _ code) = code
462 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
464 registerName :: Register -> Reg -> Reg
465 registerName (Fixed _ reg _) _ = reg
466 registerName (Any _ _) reg = reg
468 registerNameF (Fixed _ reg _) = reg
469 registerNameF (Any _ _) = panic "registerNameF"
471 registerRep :: Register -> PrimRep
472 registerRep (Fixed pk _ _) = pk
473 registerRep (Any pk _) = pk
475 swizzleRegisterRep :: Register -> PrimRep -> Register
476 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
477 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
479 {-# INLINE registerCode #-}
480 {-# INLINE registerCodeF #-}
481 {-# INLINE registerName #-}
482 {-# INLINE registerNameF #-}
483 {-# INLINE registerRep #-}
484 {-# INLINE isFixed #-}
487 isFixed, isAny :: Register -> Bool
488 isFixed (Fixed _ _ _) = True
489 isFixed (Any _ _) = False
491 isAny = not . isFixed
494 Generate code to get a subtree into a @Register@:
497 getRegisterReg :: StixReg -> NatM Register
498 getRegister :: StixExpr -> NatM Register
501 getRegisterReg (StixMagicId mid)
502 = case get_MagicId_reg_or_addr mid of
504 -> let pk = magicIdPrimRep mid
505 in returnNat (Fixed pk (RealReg rrno) nilOL)
507 -- By this stage, the only MagicIds remaining should be the
508 -- ones which map to a real machine register on this platform. Hence ...
509 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
511 getRegisterReg (StixTemp (StixVReg u pk))
512 = returnNat (Fixed pk (mkVReg u pk) nilOL)
516 -- Don't delete this -- it's very handy for debugging.
518 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
519 -- = panic "getRegister(???)"
521 getRegister (StReg reg)
524 getRegister tree@(StIndex _ _ _)
525 = getRegister (mangleIndexTree tree)
527 getRegister (StCall fn cconv kind args)
528 | not (ncg_target_is_32bit && is64BitRep kind)
529 = genCCall fn cconv kind args `thenNat` \ call ->
530 returnNat (Fixed kind reg call)
532 reg = if isFloatingRep kind
533 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
534 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
536 getRegister (StString s)
537 = getNatLabelNCG `thenNat` \ lbl ->
539 imm_lbl = ImmCLbl lbl
542 SEGMENT RoDataSegment,
544 ASCII True (_UNPK_ s),
546 #if alpha_TARGET_ARCH
547 LDA dst (AddrImm imm_lbl)
550 MOV L (OpImm imm_lbl) (OpReg dst)
552 #if sparc_TARGET_ARCH
553 SETHI (HI imm_lbl) dst,
554 OR False dst (RIImm (LO imm_lbl)) dst
558 returnNat (Any PtrRep code)
560 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
561 -- end of machine-"independent" bit; here we go on the rest...
563 #if alpha_TARGET_ARCH
565 getRegister (StDouble d)
566 = getNatLabelNCG `thenNat` \ lbl ->
567 getNewRegNCG PtrRep `thenNat` \ tmp ->
568 let code dst = mkSeqInstrs [
571 DATA TF [ImmLab (rational d)],
573 LDA tmp (AddrImm (ImmCLbl lbl)),
574 LD TF dst (AddrReg tmp)]
576 returnNat (Any DoubleRep code)
578 getRegister (StPrim primop [x]) -- unary PrimOps
580 IntNegOp -> trivialUCode (NEG Q False) x
582 NotOp -> trivialUCode NOT x
584 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
585 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
587 OrdOp -> coerceIntCode IntRep x
590 Float2IntOp -> coerceFP2Int x
591 Int2FloatOp -> coerceInt2FP pr x
592 Double2IntOp -> coerceFP2Int x
593 Int2DoubleOp -> coerceInt2FP pr x
595 Double2FloatOp -> coerceFltCode x
596 Float2DoubleOp -> coerceFltCode x
598 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
600 fn = case other_op of
601 FloatExpOp -> SLIT("exp")
602 FloatLogOp -> SLIT("log")
603 FloatSqrtOp -> SLIT("sqrt")
604 FloatSinOp -> SLIT("sin")
605 FloatCosOp -> SLIT("cos")
606 FloatTanOp -> SLIT("tan")
607 FloatAsinOp -> SLIT("asin")
608 FloatAcosOp -> SLIT("acos")
609 FloatAtanOp -> SLIT("atan")
610 FloatSinhOp -> SLIT("sinh")
611 FloatCoshOp -> SLIT("cosh")
612 FloatTanhOp -> SLIT("tanh")
613 DoubleExpOp -> SLIT("exp")
614 DoubleLogOp -> SLIT("log")
615 DoubleSqrtOp -> SLIT("sqrt")
616 DoubleSinOp -> SLIT("sin")
617 DoubleCosOp -> SLIT("cos")
618 DoubleTanOp -> SLIT("tan")
619 DoubleAsinOp -> SLIT("asin")
620 DoubleAcosOp -> SLIT("acos")
621 DoubleAtanOp -> SLIT("atan")
622 DoubleSinhOp -> SLIT("sinh")
623 DoubleCoshOp -> SLIT("cosh")
624 DoubleTanhOp -> SLIT("tanh")
626 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
628 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
630 CharGtOp -> trivialCode (CMP LTT) y x
631 CharGeOp -> trivialCode (CMP LE) y x
632 CharEqOp -> trivialCode (CMP EQQ) x y
633 CharNeOp -> int_NE_code x y
634 CharLtOp -> trivialCode (CMP LTT) x y
635 CharLeOp -> trivialCode (CMP LE) x y
637 IntGtOp -> trivialCode (CMP LTT) y x
638 IntGeOp -> trivialCode (CMP LE) y x
639 IntEqOp -> trivialCode (CMP EQQ) x y
640 IntNeOp -> int_NE_code x y
641 IntLtOp -> trivialCode (CMP LTT) x y
642 IntLeOp -> trivialCode (CMP LE) x y
644 WordGtOp -> trivialCode (CMP ULT) y x
645 WordGeOp -> trivialCode (CMP ULE) x y
646 WordEqOp -> trivialCode (CMP EQQ) x y
647 WordNeOp -> int_NE_code x y
648 WordLtOp -> trivialCode (CMP ULT) x y
649 WordLeOp -> trivialCode (CMP ULE) x y
651 AddrGtOp -> trivialCode (CMP ULT) y x
652 AddrGeOp -> trivialCode (CMP ULE) y x
653 AddrEqOp -> trivialCode (CMP EQQ) x y
654 AddrNeOp -> int_NE_code x y
655 AddrLtOp -> trivialCode (CMP ULT) x y
656 AddrLeOp -> trivialCode (CMP ULE) x y
658 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
659 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
660 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
661 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
662 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
663 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
665 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
666 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
667 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
668 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
669 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
670 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
672 IntAddOp -> trivialCode (ADD Q False) x y
673 IntSubOp -> trivialCode (SUB Q False) x y
674 IntMulOp -> trivialCode (MUL Q False) x y
675 IntQuotOp -> trivialCode (DIV Q False) x y
676 IntRemOp -> trivialCode (REM Q False) x y
678 WordAddOp -> trivialCode (ADD Q False) x y
679 WordSubOp -> trivialCode (SUB Q False) x y
680 WordMulOp -> trivialCode (MUL Q False) x y
681 WordQuotOp -> trivialCode (DIV Q True) x y
682 WordRemOp -> trivialCode (REM Q True) x y
684 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
685 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
686 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
687 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
689 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
690 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
691 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
692 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
694 AddrAddOp -> trivialCode (ADD Q False) x y
695 AddrSubOp -> trivialCode (SUB Q False) x y
696 AddrRemOp -> trivialCode (REM Q True) x y
698 AndOp -> trivialCode AND x y
699 OrOp -> trivialCode OR x y
700 XorOp -> trivialCode XOR x y
701 SllOp -> trivialCode SLL x y
702 SrlOp -> trivialCode SRL x y
704 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
705 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
706 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
708 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
709 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
711 {- ------------------------------------------------------------
712 Some bizarre special code for getting condition codes into
713 registers. Integer non-equality is a test for equality
714 followed by an XOR with 1. (Integer comparisons always set
715 the result register to 0 or 1.) Floating point comparisons of
716 any kind leave the result in a floating point register, so we
717 need to wrangle an integer register out of things.
719 int_NE_code :: StixTree -> StixTree -> NatM Register
722 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
723 getNewRegNCG IntRep `thenNat` \ tmp ->
725 code = registerCode register tmp
726 src = registerName register tmp
727 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
729 returnNat (Any IntRep code__2)
731 {- ------------------------------------------------------------
732 Comments for int_NE_code also apply to cmpF_code
735 :: (Reg -> Reg -> Reg -> Instr)
737 -> StixTree -> StixTree
740 cmpF_code instr cond x y
741 = trivialFCode pr instr x y `thenNat` \ register ->
742 getNewRegNCG DoubleRep `thenNat` \ tmp ->
743 getNatLabelNCG `thenNat` \ lbl ->
745 code = registerCode register tmp
746 result = registerName register tmp
748 code__2 dst = code . mkSeqInstrs [
749 OR zeroh (RIImm (ImmInt 1)) dst,
750 BF cond result (ImmCLbl lbl),
751 OR zeroh (RIReg zeroh) dst,
754 returnNat (Any IntRep code__2)
756 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
757 ------------------------------------------------------------
759 getRegister (StInd pk mem)
760 = getAmode mem `thenNat` \ amode ->
762 code = amodeCode amode
763 src = amodeAddr amode
764 size = primRepToSize pk
765 code__2 dst = code . mkSeqInstr (LD size dst src)
767 returnNat (Any pk code__2)
769 getRegister (StInt i)
772 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
774 returnNat (Any IntRep code)
777 code dst = mkSeqInstr (LDI Q dst src)
779 returnNat (Any IntRep code)
781 src = ImmInt (fromInteger i)
786 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
788 returnNat (Any PtrRep code)
791 imm__2 = case imm of Just x -> x
793 #endif {- alpha_TARGET_ARCH -}
795 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
799 getRegister (StFloat f)
800 = getNatLabelNCG `thenNat` \ lbl ->
801 let code dst = toOL [
806 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
809 returnNat (Any FloatRep code)
812 getRegister (StDouble d)
815 = let code dst = unitOL (GLDZ dst)
816 in returnNat (Any DoubleRep code)
819 = let code dst = unitOL (GLD1 dst)
820 in returnNat (Any DoubleRep code)
823 = getNatLabelNCG `thenNat` \ lbl ->
824 let code dst = toOL [
827 DATA DF [ImmDouble d],
829 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
832 returnNat (Any DoubleRep code)
835 getRegister (StMachOp mop [x]) -- unary MachOps
837 MO_NatS_Neg -> trivialUCode (NEGI L) x
838 MO_Nat_Not -> trivialUCode (NOT L) x
840 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
841 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
843 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
844 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
846 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
847 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
849 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
850 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
852 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
853 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
855 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
856 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
857 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
858 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
860 -- Conversions which are a nop on x86
861 MO_NatS_to_32U -> conversionNop WordRep x
862 MO_32U_to_NatS -> conversionNop IntRep x
864 MO_NatU_to_NatS -> conversionNop IntRep x
865 MO_NatS_to_NatU -> conversionNop WordRep x
866 MO_NatP_to_NatU -> conversionNop WordRep x
867 MO_NatU_to_NatP -> conversionNop PtrRep x
868 MO_NatS_to_NatP -> conversionNop PtrRep x
869 MO_NatP_to_NatS -> conversionNop IntRep x
871 MO_Dbl_to_Flt -> conversionNop FloatRep x
872 MO_Flt_to_Dbl -> conversionNop DoubleRep x
874 -- sign-extending widenings
875 MO_8U_to_NatU -> integerExtend False 24 x
876 MO_8S_to_NatS -> integerExtend True 24 x
877 MO_16U_to_NatU -> integerExtend False 16 x
878 MO_16S_to_NatS -> integerExtend True 16 x
882 (if is_float_op then demote else id)
883 (StCall fn CCallConv DoubleRep
884 [(if is_float_op then promote else id) x])
887 integerExtend signed nBits x
889 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
890 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
893 conversionNop new_rep expr
894 = getRegister expr `thenNat` \ e_code ->
895 returnNat (swizzleRegisterRep e_code new_rep)
897 promote x = StMachOp MO_Flt_to_Dbl [x]
898 demote x = StMachOp MO_Dbl_to_Flt [x]
901 MO_Flt_Exp -> (True, SLIT("exp"))
902 MO_Flt_Log -> (True, SLIT("log"))
904 MO_Flt_Asin -> (True, SLIT("asin"))
905 MO_Flt_Acos -> (True, SLIT("acos"))
906 MO_Flt_Atan -> (True, SLIT("atan"))
908 MO_Flt_Sinh -> (True, SLIT("sinh"))
909 MO_Flt_Cosh -> (True, SLIT("cosh"))
910 MO_Flt_Tanh -> (True, SLIT("tanh"))
912 MO_Dbl_Exp -> (False, SLIT("exp"))
913 MO_Dbl_Log -> (False, SLIT("log"))
915 MO_Dbl_Asin -> (False, SLIT("asin"))
916 MO_Dbl_Acos -> (False, SLIT("acos"))
917 MO_Dbl_Atan -> (False, SLIT("atan"))
919 MO_Dbl_Sinh -> (False, SLIT("sinh"))
920 MO_Dbl_Cosh -> (False, SLIT("cosh"))
921 MO_Dbl_Tanh -> (False, SLIT("tanh"))
923 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
927 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
929 MO_32U_Gt -> condIntReg GTT x y
930 MO_32U_Ge -> condIntReg GE x y
931 MO_32U_Eq -> condIntReg EQQ x y
932 MO_32U_Ne -> condIntReg NE x y
933 MO_32U_Lt -> condIntReg LTT x y
934 MO_32U_Le -> condIntReg LE x y
936 MO_Nat_Eq -> condIntReg EQQ x y
937 MO_Nat_Ne -> condIntReg NE x y
939 MO_NatS_Gt -> condIntReg GTT x y
940 MO_NatS_Ge -> condIntReg GE x y
941 MO_NatS_Lt -> condIntReg LTT x y
942 MO_NatS_Le -> condIntReg LE x y
944 MO_NatU_Gt -> condIntReg GU x y
945 MO_NatU_Ge -> condIntReg GEU x y
946 MO_NatU_Lt -> condIntReg LU x y
947 MO_NatU_Le -> condIntReg LEU x y
949 MO_Flt_Gt -> condFltReg GTT x y
950 MO_Flt_Ge -> condFltReg GE x y
951 MO_Flt_Eq -> condFltReg EQQ x y
952 MO_Flt_Ne -> condFltReg NE x y
953 MO_Flt_Lt -> condFltReg LTT x y
954 MO_Flt_Le -> condFltReg LE x y
956 MO_Dbl_Gt -> condFltReg GTT x y
957 MO_Dbl_Ge -> condFltReg GE x y
958 MO_Dbl_Eq -> condFltReg EQQ x y
959 MO_Dbl_Ne -> condFltReg NE x y
960 MO_Dbl_Lt -> condFltReg LTT x y
961 MO_Dbl_Le -> condFltReg LE x y
963 MO_Nat_Add -> add_code L x y
964 MO_Nat_Sub -> sub_code L x y
965 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
966 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
967 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
968 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
969 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
970 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
972 MO_Flt_Add -> trivialFCode FloatRep GADD x y
973 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
974 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
975 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
977 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
978 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
979 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
980 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
982 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
983 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
984 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
986 {- Shift ops on x86s have constraints on their source, it
987 either has to be Imm, CL or 1
988 => trivialCode's is not restrictive enough (sigh.)
990 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
991 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
992 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
994 MO_Flt_Pwr -> getRegister (demote
995 (StCall SLIT("pow") CCallConv DoubleRep
996 [promote x, promote y])
998 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1000 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1002 promote x = StMachOp MO_Flt_to_Dbl [x]
1003 demote x = StMachOp MO_Dbl_to_Flt [x]
1005 --------------------
1006 shift_code :: (Imm -> Operand -> Instr)
1011 {- Case1: shift length as immediate -}
1012 -- Code is the same as the first eq. for trivialCode -- sigh.
1013 shift_code instr x y{-amount-}
1015 = getRegister x `thenNat` \ regx ->
1018 then registerCodeA regx dst `bind` \ code_x ->
1020 instr imm__2 (OpReg dst)
1021 else registerCodeF regx `bind` \ code_x ->
1022 registerNameF regx `bind` \ r_x ->
1024 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1025 instr imm__2 (OpReg dst)
1027 returnNat (Any IntRep mkcode)
1030 imm__2 = case imm of Just x -> x
1032 {- Case2: shift length is complex (non-immediate) -}
1033 -- Since ECX is always used as a spill temporary, we can't
1034 -- use it here to do non-immediate shifts. No big deal --
1035 -- they are only very rare, and we can use an equivalent
1036 -- test-and-jump sequence which doesn't use ECX.
1037 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1038 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1039 shift_code instr x y{-amount-}
1040 = getRegister x `thenNat` \ register1 ->
1041 getRegister y `thenNat` \ register2 ->
1042 getNatLabelNCG `thenNat` \ lbl_test3 ->
1043 getNatLabelNCG `thenNat` \ lbl_test2 ->
1044 getNatLabelNCG `thenNat` \ lbl_test1 ->
1045 getNatLabelNCG `thenNat` \ lbl_test0 ->
1046 getNatLabelNCG `thenNat` \ lbl_after ->
1047 getNewRegNCG IntRep `thenNat` \ tmp ->
1049 = let src_val = registerName register1 dst
1050 code_val = registerCode register1 dst
1051 src_amt = registerName register2 tmp
1052 code_amt = registerCode register2 tmp
1057 MOV L (OpReg src_amt) r_tmp `appOL`
1059 MOV L (OpReg src_val) r_dst `appOL`
1061 COMMENT (_PK_ "begin shift sequence"),
1062 MOV L (OpReg src_val) r_dst,
1063 MOV L (OpReg src_amt) r_tmp,
1065 BT L (ImmInt 4) r_tmp,
1067 instr (ImmInt 16) r_dst,
1070 BT L (ImmInt 3) r_tmp,
1072 instr (ImmInt 8) r_dst,
1075 BT L (ImmInt 2) r_tmp,
1077 instr (ImmInt 4) r_dst,
1080 BT L (ImmInt 1) r_tmp,
1082 instr (ImmInt 2) r_dst,
1085 BT L (ImmInt 0) r_tmp,
1087 instr (ImmInt 1) r_dst,
1090 COMMENT (_PK_ "end shift sequence")
1093 returnNat (Any IntRep code__2)
1095 --------------------
1096 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1098 add_code sz x (StInt y)
1099 = getRegister x `thenNat` \ register ->
1100 getNewRegNCG IntRep `thenNat` \ tmp ->
1102 code = registerCode register tmp
1103 src1 = registerName register tmp
1104 src2 = ImmInt (fromInteger y)
1107 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1110 returnNat (Any IntRep code__2)
1112 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1114 --------------------
1115 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1117 sub_code sz x (StInt y)
1118 = getRegister x `thenNat` \ register ->
1119 getNewRegNCG IntRep `thenNat` \ tmp ->
1121 code = registerCode register tmp
1122 src1 = registerName register tmp
1123 src2 = ImmInt (-(fromInteger y))
1126 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1129 returnNat (Any IntRep code__2)
1131 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1133 getRegister (StInd pk mem)
1134 | not (is64BitRep pk)
1135 = getAmode mem `thenNat` \ amode ->
1137 code = amodeCode amode
1138 src = amodeAddr amode
1139 size = primRepToSize pk
1140 code__2 dst = code `snocOL`
1141 if pk == DoubleRep || pk == FloatRep
1142 then GLD size src dst
1150 (OpAddr src) (OpReg dst)
1152 returnNat (Any pk code__2)
1154 getRegister (StInt i)
1156 src = ImmInt (fromInteger i)
1159 = unitOL (XOR L (OpReg dst) (OpReg dst))
1161 = unitOL (MOV L (OpImm src) (OpReg dst))
1163 returnNat (Any IntRep code)
1167 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1169 returnNat (Any PtrRep code)
1171 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1174 imm__2 = case imm of Just x -> x
1178 assignMachOp (Just2 sv_rr sv_cc) mop [aa,bb]
1179 | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
1180 = getRegister aa `thenNat` \ registeraa ->
1181 getRegister bb `thenNat` \ registerbb ->
1182 getNewRegNCG IntRep `thenNat` \ tmp ->
1183 getNewRegNCG IntRep `thenNat` \ tmpaa ->
1184 getNewRegNCG IntRep `thenNat` \ tmpbb ->
1185 let stixVReg_to_VReg (StixVReg u rep) = mkVReg u rep
1186 rr = stixVReg_to_VReg sv_rr
1187 cc = stixVReg_to_VReg sv_cc
1188 codeaa = registerCode registeraa tmpaa
1189 srcaa = registerName registeraa tmpaa
1190 codebb = registerCode registerbb tmpbb
1191 srcbb = registerName registerbb tmpbb
1193 insn = case mop of MO_NatS_AddC -> ADD; MO_NatS_SubC -> SUB
1194 MO_NatS_MulC -> IMUL
1195 cond = if mop == MO_NatS_MulC then OFLO else CARRY
1196 str = showSDoc (pprMachOp mop)
1199 COMMENT (_PK_ ("begin " ++ str)),
1200 MOV L (OpReg srcbb) (OpReg tmp),
1201 insn L (OpReg srcaa) (OpReg tmp),
1202 MOV L (OpReg tmp) (OpReg rr),
1203 MOV L (OpImm (ImmInt 0)) (OpReg eax),
1204 SETCC cond (OpReg eax),
1205 MOV L (OpReg eax) (OpReg cc),
1206 COMMENT (_PK_ ("end " ++ str))
1209 returnNat (codeaa `appOL` codebb `appOL` code)
1211 #endif {- i386_TARGET_ARCH -}
1213 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1215 #if sparc_TARGET_ARCH
1217 getRegister (StFloat d)
1218 = getNatLabelNCG `thenNat` \ lbl ->
1219 getNewRegNCG PtrRep `thenNat` \ tmp ->
1220 let code dst = toOL [
1221 SEGMENT DataSegment,
1223 DATA F [ImmFloat d],
1224 SEGMENT TextSegment,
1225 SETHI (HI (ImmCLbl lbl)) tmp,
1226 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1228 returnNat (Any FloatRep code)
1230 getRegister (StDouble d)
1231 = getNatLabelNCG `thenNat` \ lbl ->
1232 getNewRegNCG PtrRep `thenNat` \ tmp ->
1233 let code dst = toOL [
1234 SEGMENT DataSegment,
1236 DATA DF [ImmDouble d],
1237 SEGMENT TextSegment,
1238 SETHI (HI (ImmCLbl lbl)) tmp,
1239 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1241 returnNat (Any DoubleRep code)
1244 getRegister (StMachOp mop [x]) -- unary PrimOps
1246 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1247 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1249 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1250 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1252 MO_Dbl_to_Flt -> coerceDbl2Flt x
1253 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1255 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1256 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1257 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1258 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1260 -- Conversions which are a nop on sparc
1261 MO_32U_to_NatS -> conversionNop IntRep x
1262 MO_NatS_to_32U -> conversionNop WordRep x
1264 MO_NatU_to_NatS -> conversionNop IntRep x
1265 MO_NatS_to_NatU -> conversionNop WordRep x
1266 MO_NatP_to_NatU -> conversionNop WordRep x
1267 MO_NatU_to_NatP -> conversionNop PtrRep x
1268 MO_NatS_to_NatP -> conversionNop PtrRep x
1269 MO_NatP_to_NatS -> conversionNop IntRep x
1271 -- sign-extending widenings
1272 MO_8U_to_NatU -> integerExtend False 24 x
1273 MO_8S_to_NatS -> integerExtend True 24 x
1274 MO_16U_to_NatU -> integerExtend False 16 x
1275 MO_16S_to_NatS -> integerExtend True 16 x
1278 let fixed_x = if is_float_op -- promote to double
1279 then StMachOp MO_Flt_to_Dbl [x]
1282 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1284 integerExtend signed nBits x
1286 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1287 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
1289 conversionNop new_rep expr
1290 = getRegister expr `thenNat` \ e_code ->
1291 returnNat (swizzleRegisterRep e_code new_rep)
1295 MO_Flt_Exp -> (True, SLIT("exp"))
1296 MO_Flt_Log -> (True, SLIT("log"))
1297 MO_Flt_Sqrt -> (True, SLIT("sqrt"))
1299 MO_Flt_Sin -> (True, SLIT("sin"))
1300 MO_Flt_Cos -> (True, SLIT("cos"))
1301 MO_Flt_Tan -> (True, SLIT("tan"))
1303 MO_Flt_Asin -> (True, SLIT("asin"))
1304 MO_Flt_Acos -> (True, SLIT("acos"))
1305 MO_Flt_Atan -> (True, SLIT("atan"))
1307 MO_Flt_Sinh -> (True, SLIT("sinh"))
1308 MO_Flt_Cosh -> (True, SLIT("cosh"))
1309 MO_Flt_Tanh -> (True, SLIT("tanh"))
1311 MO_Dbl_Exp -> (False, SLIT("exp"))
1312 MO_Dbl_Log -> (False, SLIT("log"))
1313 MO_Dbl_Sqrt -> (False, SLIT("sqrt"))
1315 MO_Dbl_Sin -> (False, SLIT("sin"))
1316 MO_Dbl_Cos -> (False, SLIT("cos"))
1317 MO_Dbl_Tan -> (False, SLIT("tan"))
1319 MO_Dbl_Asin -> (False, SLIT("asin"))
1320 MO_Dbl_Acos -> (False, SLIT("acos"))
1321 MO_Dbl_Atan -> (False, SLIT("atan"))
1323 MO_Dbl_Sinh -> (False, SLIT("sinh"))
1324 MO_Dbl_Cosh -> (False, SLIT("cosh"))
1325 MO_Dbl_Tanh -> (False, SLIT("tanh"))
1327 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1331 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1333 MO_32U_Gt -> condIntReg GTT x y
1334 MO_32U_Ge -> condIntReg GE x y
1335 MO_32U_Eq -> condIntReg EQQ x y
1336 MO_32U_Ne -> condIntReg NE x y
1337 MO_32U_Lt -> condIntReg LTT x y
1338 MO_32U_Le -> condIntReg LE x y
1340 MO_Nat_Eq -> condIntReg EQQ x y
1341 MO_Nat_Ne -> condIntReg NE x y
1343 MO_NatS_Gt -> condIntReg GTT x y
1344 MO_NatS_Ge -> condIntReg GE x y
1345 MO_NatS_Lt -> condIntReg LTT x y
1346 MO_NatS_Le -> condIntReg LE x y
1348 MO_NatU_Gt -> condIntReg GU x y
1349 MO_NatU_Ge -> condIntReg GEU x y
1350 MO_NatU_Lt -> condIntReg LU x y
1351 MO_NatU_Le -> condIntReg LEU x y
1353 MO_Flt_Gt -> condFltReg GTT x y
1354 MO_Flt_Ge -> condFltReg GE x y
1355 MO_Flt_Eq -> condFltReg EQQ x y
1356 MO_Flt_Ne -> condFltReg NE x y
1357 MO_Flt_Lt -> condFltReg LTT x y
1358 MO_Flt_Le -> condFltReg LE x y
1360 MO_Dbl_Gt -> condFltReg GTT x y
1361 MO_Dbl_Ge -> condFltReg GE x y
1362 MO_Dbl_Eq -> condFltReg EQQ x y
1363 MO_Dbl_Ne -> condFltReg NE x y
1364 MO_Dbl_Lt -> condFltReg LTT x y
1365 MO_Dbl_Le -> condFltReg LE x y
1367 MO_Nat_Add -> trivialCode (ADD False False) x y
1368 MO_Nat_Sub -> trivialCode (SUB False False) x y
1370 -- ToDo: teach about V8+ SPARC mul/div instructions
1371 MO_NatS_Quot -> imul_div SLIT(".div") x y
1372 MO_NatS_Rem -> imul_div SLIT(".rem") x y
1373 MO_NatU_Quot -> imul_div SLIT(".udiv") x y
1374 MO_NatU_Rem -> imul_div SLIT(".urem") x y
1376 MO_NatS_Mul -> imul_div SLIT(".umul") x y
1377 MO_NatU_Mul -> imul_div SLIT(".umul") x y
1379 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1380 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1381 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1382 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1384 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1385 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1386 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1387 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1389 MO_Nat_And -> trivialCode (AND False) x y
1390 MO_Nat_Or -> trivialCode (OR False) x y
1391 MO_Nat_Xor -> trivialCode (XOR False) x y
1393 MO_Nat_Shl -> trivialCode SLL x y
1394 MO_Nat_Shr -> trivialCode SRL x y
1395 MO_Nat_Sar -> trivialCode SRA x y
1397 MO_Flt_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1398 [promote x, promote y])
1399 where promote x = StMachOp MO_Flt_to_Dbl [x]
1400 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1403 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1405 imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1407 getRegister (StInd pk mem)
1408 = getAmode mem `thenNat` \ amode ->
1410 code = amodeCode amode
1411 src = amodeAddr amode
1412 size = primRepToSize pk
1413 code__2 dst = code `snocOL` LD size src dst
1415 returnNat (Any pk code__2)
1417 getRegister (StInt i)
1420 src = ImmInt (fromInteger i)
1421 code dst = unitOL (OR False g0 (RIImm src) dst)
1423 returnNat (Any IntRep code)
1429 SETHI (HI imm__2) dst,
1430 OR False dst (RIImm (LO imm__2)) dst]
1432 returnNat (Any PtrRep code)
1434 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1437 imm__2 = case imm of Just x -> x
1441 assignMachOp (Just2 sv_rr sv_cc) mop [aa,bb]
1442 = panic "assignMachOp(sparc)"
1444 | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
1445 = getRegister aa `thenNat` \ registeraa ->
1446 getRegister bb `thenNat` \ registerbb ->
1447 getNewRegNCG IntRep `thenNat` \ tmp ->
1448 getNewRegNCG IntRep `thenNat` \ tmpaa ->
1449 getNewRegNCG IntRep `thenNat` \ tmpbb ->
1450 let stixVReg_to_VReg (StixVReg u rep) = mkVReg u rep
1451 rr = stixVReg_to_VReg sv_rr
1452 cc = stixVReg_to_VReg sv_cc
1453 codeaa = registerCode registeraa tmpaa
1454 srcaa = registerName registeraa tmpaa
1455 codebb = registerCode registerbb tmpbb
1456 srcbb = registerName registerbb tmpbb
1458 insn = case mop of MO_NatS_AddC -> ADD; MO_NatS_SubC -> SUB
1459 MO_NatS_MulC -> IMUL
1460 cond = if mop == MO_NatS_MulC then OFLO else CARRY
1461 str = showSDoc (pprMachOp mop)
1464 COMMENT (_PK_ ("begin " ++ str)),
1465 MOV L (OpReg srcbb) (OpReg tmp),
1466 insn L (OpReg srcaa) (OpReg tmp),
1467 MOV L (OpReg tmp) (OpReg rr),
1468 MOV L (OpImm (ImmInt 0)) (OpReg eax),
1469 SETCC cond (OpReg eax),
1470 MOV L (OpReg eax) (OpReg cc),
1471 COMMENT (_PK_ ("end " ++ str))
1474 returnNat (codeaa `appOL` codebb `appOL` code)
1476 #endif {- sparc_TARGET_ARCH -}
1478 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1482 %************************************************************************
1484 \subsection{The @Amode@ type}
1486 %************************************************************************
1488 @Amode@s: Memory addressing modes passed up the tree.
1490 data Amode = Amode MachRegsAddr InstrBlock
1492 amodeAddr (Amode addr _) = addr
1493 amodeCode (Amode _ code) = code
1496 Now, given a tree (the argument to an StInd) that references memory,
1497 produce a suitable addressing mode.
1499 A Rule of the Game (tm) for Amodes: use of the addr bit must
1500 immediately follow use of the code part, since the code part puts
1501 values in registers which the addr then refers to. So you can't put
1502 anything in between, lest it overwrite some of those registers. If
1503 you need to do some other computation between the code part and use of
1504 the addr bit, first store the effective address from the amode in a
1505 temporary, then do the other computation, and then use the temporary:
1509 ... other computation ...
1513 getAmode :: StixExpr -> NatM Amode
1515 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1517 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1519 #if alpha_TARGET_ARCH
1521 getAmode (StPrim IntSubOp [x, StInt i])
1522 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1523 getRegister x `thenNat` \ register ->
1525 code = registerCode register tmp
1526 reg = registerName register tmp
1527 off = ImmInt (-(fromInteger i))
1529 returnNat (Amode (AddrRegImm reg off) code)
1531 getAmode (StPrim IntAddOp [x, StInt i])
1532 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1533 getRegister x `thenNat` \ register ->
1535 code = registerCode register tmp
1536 reg = registerName register tmp
1537 off = ImmInt (fromInteger i)
1539 returnNat (Amode (AddrRegImm reg off) code)
1543 = returnNat (Amode (AddrImm imm__2) id)
1546 imm__2 = case imm of Just x -> x
1549 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1550 getRegister other `thenNat` \ register ->
1552 code = registerCode register tmp
1553 reg = registerName register tmp
1555 returnNat (Amode (AddrReg reg) code)
1557 #endif {- alpha_TARGET_ARCH -}
1559 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1561 #if i386_TARGET_ARCH
1563 -- This is all just ridiculous, since it carefully undoes
1564 -- what mangleIndexTree has just done.
1565 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1566 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1567 getRegister x `thenNat` \ register ->
1569 code = registerCode register tmp
1570 reg = registerName register tmp
1571 off = ImmInt (-(fromInteger i))
1573 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1575 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1577 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1580 imm__2 = case imm of Just x -> x
1582 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1583 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1584 getRegister x `thenNat` \ register ->
1586 code = registerCode register tmp
1587 reg = registerName register tmp
1588 off = ImmInt (fromInteger i)
1590 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1592 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1593 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1594 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1595 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1596 getRegister x `thenNat` \ register1 ->
1597 getRegister y `thenNat` \ register2 ->
1599 code1 = registerCode register1 tmp1
1600 reg1 = registerName register1 tmp1
1601 code2 = registerCode register2 tmp2
1602 reg2 = registerName register2 tmp2
1603 code__2 = code1 `appOL` code2
1604 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1606 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1611 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1614 imm__2 = case imm of Just x -> x
1617 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1618 getRegister other `thenNat` \ register ->
1620 code = registerCode register tmp
1621 reg = registerName register tmp
1623 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1625 #endif {- i386_TARGET_ARCH -}
1627 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1629 #if sparc_TARGET_ARCH
1631 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1633 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1634 getRegister x `thenNat` \ register ->
1636 code = registerCode register tmp
1637 reg = registerName register tmp
1638 off = ImmInt (-(fromInteger i))
1640 returnNat (Amode (AddrRegImm reg off) code)
1643 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1645 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1646 getRegister x `thenNat` \ register ->
1648 code = registerCode register tmp
1649 reg = registerName register tmp
1650 off = ImmInt (fromInteger i)
1652 returnNat (Amode (AddrRegImm reg off) code)
1654 getAmode (StMachOp MO_Nat_Add [x, y])
1655 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1656 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1657 getRegister x `thenNat` \ register1 ->
1658 getRegister y `thenNat` \ register2 ->
1660 code1 = registerCode register1 tmp1
1661 reg1 = registerName register1 tmp1
1662 code2 = registerCode register2 tmp2
1663 reg2 = registerName register2 tmp2
1664 code__2 = code1 `appOL` code2
1666 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1670 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1672 code = unitOL (SETHI (HI imm__2) tmp)
1674 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1677 imm__2 = case imm of Just x -> x
1680 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1681 getRegister other `thenNat` \ register ->
1683 code = registerCode register tmp
1684 reg = registerName register tmp
1687 returnNat (Amode (AddrRegImm reg off) code)
1689 #endif {- sparc_TARGET_ARCH -}
1691 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1694 %************************************************************************
1696 \subsection{The @CondCode@ type}
1698 %************************************************************************
1700 Condition codes passed up the tree.
1702 data CondCode = CondCode Bool Cond InstrBlock
1704 condName (CondCode _ cond _) = cond
1705 condFloat (CondCode is_float _ _) = is_float
1706 condCode (CondCode _ _ code) = code
1709 Set up a condition code for a conditional branch.
1712 getCondCode :: StixExpr -> NatM CondCode
1714 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1716 #if alpha_TARGET_ARCH
1717 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1718 #endif {- alpha_TARGET_ARCH -}
1720 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1722 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1723 -- yes, they really do seem to want exactly the same!
1725 getCondCode (StMachOp mop [x, y])
1727 MO_32U_Gt -> condIntCode GTT x y
1728 MO_32U_Ge -> condIntCode GE x y
1729 MO_32U_Eq -> condIntCode EQQ x y
1730 MO_32U_Ne -> condIntCode NE x y
1731 MO_32U_Lt -> condIntCode LTT x y
1732 MO_32U_Le -> condIntCode LE x y
1734 MO_Nat_Eq -> condIntCode EQQ x y
1735 MO_Nat_Ne -> condIntCode NE x y
1737 MO_NatS_Gt -> condIntCode GTT x y
1738 MO_NatS_Ge -> condIntCode GE x y
1739 MO_NatS_Lt -> condIntCode LTT x y
1740 MO_NatS_Le -> condIntCode LE x y
1742 MO_NatU_Gt -> condIntCode GU x y
1743 MO_NatU_Ge -> condIntCode GEU x y
1744 MO_NatU_Lt -> condIntCode LU x y
1745 MO_NatU_Le -> condIntCode LEU x y
1747 MO_Flt_Gt -> condFltCode GTT x y
1748 MO_Flt_Ge -> condFltCode GE x y
1749 MO_Flt_Eq -> condFltCode EQQ x y
1750 MO_Flt_Ne -> condFltCode NE x y
1751 MO_Flt_Lt -> condFltCode LTT x y
1752 MO_Flt_Le -> condFltCode LE x y
1754 MO_Dbl_Gt -> condFltCode GTT x y
1755 MO_Dbl_Ge -> condFltCode GE x y
1756 MO_Dbl_Eq -> condFltCode EQQ x y
1757 MO_Dbl_Ne -> condFltCode NE x y
1758 MO_Dbl_Lt -> condFltCode LTT x y
1759 MO_Dbl_Le -> condFltCode LE x y
1761 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1763 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1765 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1767 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1772 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1773 passed back up the tree.
1776 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1778 #if alpha_TARGET_ARCH
1779 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1780 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1781 #endif {- alpha_TARGET_ARCH -}
1783 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1784 #if i386_TARGET_ARCH
1786 -- memory vs immediate
1787 condIntCode cond (StInd pk x) y
1788 | Just i <- maybeImm y
1789 = getAmode x `thenNat` \ amode ->
1791 code1 = amodeCode amode
1792 x__2 = amodeAddr amode
1793 sz = primRepToSize pk
1794 code__2 = code1 `snocOL`
1795 CMP sz (OpImm i) (OpAddr x__2)
1797 returnNat (CondCode False cond code__2)
1800 condIntCode cond x (StInt 0)
1801 = getRegister x `thenNat` \ register1 ->
1802 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1804 code1 = registerCode register1 tmp1
1805 src1 = registerName register1 tmp1
1806 code__2 = code1 `snocOL`
1807 TEST L (OpReg src1) (OpReg src1)
1809 returnNat (CondCode False cond code__2)
1811 -- anything vs immediate
1812 condIntCode cond x y
1813 | Just i <- maybeImm y
1814 = getRegister x `thenNat` \ register1 ->
1815 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1817 code1 = registerCode register1 tmp1
1818 src1 = registerName register1 tmp1
1819 code__2 = code1 `snocOL`
1820 CMP L (OpImm i) (OpReg src1)
1822 returnNat (CondCode False cond code__2)
1824 -- memory vs anything
1825 condIntCode cond (StInd pk x) y
1826 = getAmode x `thenNat` \ amode_x ->
1827 getRegister y `thenNat` \ reg_y ->
1828 getNewRegNCG IntRep `thenNat` \ tmp ->
1830 c_x = amodeCode amode_x
1831 am_x = amodeAddr amode_x
1832 c_y = registerCode reg_y tmp
1833 r_y = registerName reg_y tmp
1834 sz = primRepToSize pk
1836 -- optimisation: if there's no code for x, just an amode,
1837 -- use whatever reg y winds up in. Assumes that c_y doesn't
1838 -- clobber any regs in the amode am_x, which I'm not sure is
1839 -- justified. The otherwise clause makes the same assumption.
1840 code__2 | isNilOL c_x
1842 CMP sz (OpReg r_y) (OpAddr am_x)
1846 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1848 CMP sz (OpReg tmp) (OpAddr am_x)
1850 returnNat (CondCode False cond code__2)
1852 -- anything vs memory
1854 condIntCode cond y (StInd pk x)
1855 = getAmode x `thenNat` \ amode_x ->
1856 getRegister y `thenNat` \ reg_y ->
1857 getNewRegNCG IntRep `thenNat` \ tmp ->
1859 c_x = amodeCode amode_x
1860 am_x = amodeAddr amode_x
1861 c_y = registerCode reg_y tmp
1862 r_y = registerName reg_y tmp
1863 sz = primRepToSize pk
1864 -- same optimisation and nagging doubts as previous clause
1865 code__2 | isNilOL c_x
1867 CMP sz (OpAddr am_x) (OpReg r_y)
1871 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1873 CMP sz (OpAddr am_x) (OpReg tmp)
1875 returnNat (CondCode False cond code__2)
1877 -- anything vs anything
1878 condIntCode cond x y
1879 = getRegister x `thenNat` \ register1 ->
1880 getRegister y `thenNat` \ register2 ->
1881 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1882 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1884 code1 = registerCode register1 tmp1
1885 src1 = registerName register1 tmp1
1886 code2 = registerCode register2 tmp2
1887 src2 = registerName register2 tmp2
1888 code__2 = code1 `snocOL`
1889 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1891 CMP L (OpReg src2) (OpReg tmp1)
1893 returnNat (CondCode False cond code__2)
1896 condFltCode cond x y
1897 = getRegister x `thenNat` \ register1 ->
1898 getRegister y `thenNat` \ register2 ->
1899 getNewRegNCG (registerRep register1)
1901 getNewRegNCG (registerRep register2)
1903 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1905 pk1 = registerRep register1
1906 code1 = registerCode register1 tmp1
1907 src1 = registerName register1 tmp1
1909 code2 = registerCode register2 tmp2
1910 src2 = registerName register2 tmp2
1912 code__2 | isAny register1
1913 = code1 `appOL` -- result in tmp1
1915 GCMP (primRepToSize pk1) tmp1 src2
1919 GMOV src1 tmp1 `appOL`
1921 GCMP (primRepToSize pk1) tmp1 src2
1923 {- On the 486, the flags set by FP compare are the unsigned ones!
1924 (This looks like a HACK to me. WDP 96/03)
1926 fix_FP_cond :: Cond -> Cond
1928 fix_FP_cond GE = GEU
1929 fix_FP_cond GTT = GU
1930 fix_FP_cond LTT = LU
1931 fix_FP_cond LE = LEU
1932 fix_FP_cond any = any
1934 returnNat (CondCode True (fix_FP_cond cond) code__2)
1936 #endif {- i386_TARGET_ARCH -}
1938 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1940 #if sparc_TARGET_ARCH
1942 condIntCode cond x (StInt y)
1944 = getRegister x `thenNat` \ register ->
1945 getNewRegNCG IntRep `thenNat` \ tmp ->
1947 code = registerCode register tmp
1948 src1 = registerName register tmp
1949 src2 = ImmInt (fromInteger y)
1950 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1952 returnNat (CondCode False cond code__2)
1954 condIntCode cond x y
1955 = getRegister x `thenNat` \ register1 ->
1956 getRegister y `thenNat` \ register2 ->
1957 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1958 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1960 code1 = registerCode register1 tmp1
1961 src1 = registerName register1 tmp1
1962 code2 = registerCode register2 tmp2
1963 src2 = registerName register2 tmp2
1964 code__2 = code1 `appOL` code2 `snocOL`
1965 SUB False True src1 (RIReg src2) g0
1967 returnNat (CondCode False cond code__2)
1970 condFltCode cond x y
1971 = getRegister x `thenNat` \ register1 ->
1972 getRegister y `thenNat` \ register2 ->
1973 getNewRegNCG (registerRep register1)
1975 getNewRegNCG (registerRep register2)
1977 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1979 promote x = FxTOy F DF x tmp
1981 pk1 = registerRep register1
1982 code1 = registerCode register1 tmp1
1983 src1 = registerName register1 tmp1
1985 pk2 = registerRep register2
1986 code2 = registerCode register2 tmp2
1987 src2 = registerName register2 tmp2
1991 code1 `appOL` code2 `snocOL`
1992 FCMP True (primRepToSize pk1) src1 src2
1993 else if pk1 == FloatRep then
1994 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1995 FCMP True DF tmp src2
1997 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1998 FCMP True DF src1 tmp
2000 returnNat (CondCode True cond code__2)
2002 #endif {- sparc_TARGET_ARCH -}
2004 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2007 %************************************************************************
2009 \subsection{Generating assignments}
2011 %************************************************************************
2013 Assignments are really at the heart of the whole code generation
2014 business. Almost all top-level nodes of any real importance are
2015 assignments, which correspond to loads, stores, or register transfers.
2016 If we're really lucky, some of the register transfers will go away,
2017 because we can use the destination register to complete the code
2018 generation for the right hand side. This only fails when the right
2019 hand side is forced into a fixed register (e.g. the result of a call).
2022 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2023 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2025 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2026 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2028 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2030 #if alpha_TARGET_ARCH
2032 assignIntCode pk (StInd _ dst) src
2033 = getNewRegNCG IntRep `thenNat` \ tmp ->
2034 getAmode dst `thenNat` \ amode ->
2035 getRegister src `thenNat` \ register ->
2037 code1 = amodeCode amode []
2038 dst__2 = amodeAddr amode
2039 code2 = registerCode register tmp []
2040 src__2 = registerName register tmp
2041 sz = primRepToSize pk
2042 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2046 assignIntCode pk dst src
2047 = getRegister dst `thenNat` \ register1 ->
2048 getRegister src `thenNat` \ register2 ->
2050 dst__2 = registerName register1 zeroh
2051 code = registerCode register2 dst__2
2052 src__2 = registerName register2 dst__2
2053 code__2 = if isFixed register2
2054 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2059 #endif {- alpha_TARGET_ARCH -}
2061 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2063 #if i386_TARGET_ARCH
2065 -- non-FP assignment to memory
2066 assignMem_IntCode pk addr src
2067 = getAmode addr `thenNat` \ amode ->
2068 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2069 getNewRegNCG PtrRep `thenNat` \ tmp ->
2071 -- In general, if the address computation for dst may require
2072 -- some insns preceding the addressing mode itself. So there's
2073 -- no guarantee that the code for dst and the code for src won't
2074 -- write the same register. This means either the address or
2075 -- the value needs to be copied into a temporary. We detect the
2076 -- common case where the amode has no code, and elide the copy.
2077 codea = amodeCode amode
2078 dst__a = amodeAddr amode
2080 code | isNilOL codea
2082 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2085 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2087 MOV (primRepToSize pk) opsrc
2088 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2094 -> NatM (InstrBlock,Operand) -- code, operator
2097 | Just x <- maybeImm op
2098 = returnNat (nilOL, OpImm x)
2101 = getRegister op `thenNat` \ register ->
2102 getNewRegNCG (registerRep register)
2104 let code = registerCode register tmp
2105 reg = registerName register tmp
2107 returnNat (code, OpReg reg)
2109 -- Assign; dst is a reg, rhs is mem
2110 assignReg_IntCode pk reg (StInd pks src)
2111 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2112 getAmode src `thenNat` \ amode ->
2113 getRegisterReg reg `thenNat` \ reg_dst ->
2115 c_addr = amodeCode amode
2116 am_addr = amodeAddr amode
2117 r_dst = registerName reg_dst tmp
2118 szs = primRepToSize pks
2127 code = c_addr `snocOL`
2128 opc (OpAddr am_addr) (OpReg r_dst)
2132 -- dst is a reg, but src could be anything
2133 assignReg_IntCode pk reg src
2134 = getRegisterReg reg `thenNat` \ registerd ->
2135 getRegister src `thenNat` \ registers ->
2136 getNewRegNCG IntRep `thenNat` \ tmp ->
2138 r_dst = registerName registerd tmp
2139 r_src = registerName registers r_dst
2140 c_src = registerCode registers r_dst
2142 code = c_src `snocOL`
2143 MOV L (OpReg r_src) (OpReg r_dst)
2147 #endif {- i386_TARGET_ARCH -}
2149 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2151 #if sparc_TARGET_ARCH
2153 assignMem_IntCode pk addr src
2154 = getNewRegNCG IntRep `thenNat` \ tmp ->
2155 getAmode addr `thenNat` \ amode ->
2156 getRegister src `thenNat` \ register ->
2158 code1 = amodeCode amode
2159 dst__2 = amodeAddr amode
2160 code2 = registerCode register tmp
2161 src__2 = registerName register tmp
2162 sz = primRepToSize pk
2163 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2167 assignReg_IntCode pk reg src
2168 = getRegister src `thenNat` \ register2 ->
2169 getRegisterReg reg `thenNat` \ register1 ->
2171 dst__2 = registerName register1 g0
2172 code = registerCode register2 dst__2
2173 src__2 = registerName register2 dst__2
2174 code__2 = if isFixed register2
2175 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2180 #endif {- sparc_TARGET_ARCH -}
2182 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2185 % --------------------------------
2186 Floating-point assignments:
2187 % --------------------------------
2190 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2191 #if alpha_TARGET_ARCH
2193 assignFltCode pk (StInd _ dst) src
2194 = getNewRegNCG pk `thenNat` \ tmp ->
2195 getAmode dst `thenNat` \ amode ->
2196 getRegister src `thenNat` \ register ->
2198 code1 = amodeCode amode []
2199 dst__2 = amodeAddr amode
2200 code2 = registerCode register tmp []
2201 src__2 = registerName register tmp
2202 sz = primRepToSize pk
2203 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2207 assignFltCode pk dst src
2208 = getRegister dst `thenNat` \ register1 ->
2209 getRegister src `thenNat` \ register2 ->
2211 dst__2 = registerName register1 zeroh
2212 code = registerCode register2 dst__2
2213 src__2 = registerName register2 dst__2
2214 code__2 = if isFixed register2
2215 then code . mkSeqInstr (FMOV src__2 dst__2)
2220 #endif {- alpha_TARGET_ARCH -}
2222 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2224 #if i386_TARGET_ARCH
2226 -- Floating point assignment to memory
2227 assignMem_FltCode pk addr src
2228 = getRegister src `thenNat` \ reg_src ->
2229 getRegister addr `thenNat` \ reg_addr ->
2230 getNewRegNCG pk `thenNat` \ tmp_src ->
2231 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2232 let r_src = registerName reg_src tmp_src
2233 c_src = registerCode reg_src tmp_src
2234 r_addr = registerName reg_addr tmp_addr
2235 c_addr = registerCode reg_addr tmp_addr
2236 sz = primRepToSize pk
2238 code = c_src `appOL`
2239 -- no need to preserve r_src across the addr computation,
2240 -- since r_src must be a float reg
2241 -- whilst r_addr is an int reg
2244 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2248 -- Floating point assignment to a register/temporary
2249 assignReg_FltCode pk reg src
2250 = getRegisterReg reg `thenNat` \ reg_dst ->
2251 getRegister src `thenNat` \ reg_src ->
2252 getNewRegNCG pk `thenNat` \ tmp ->
2254 r_dst = registerName reg_dst tmp
2255 r_src = registerName reg_src r_dst
2256 c_src = registerCode reg_src r_dst
2258 code = if isFixed reg_src
2259 then c_src `snocOL` GMOV r_src r_dst
2265 #endif {- i386_TARGET_ARCH -}
2267 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2269 #if sparc_TARGET_ARCH
2271 -- Floating point assignment to memory
2272 assignMem_FltCode pk addr src
2273 = getNewRegNCG pk `thenNat` \ tmp1 ->
2274 getAmode addr `thenNat` \ amode ->
2275 getRegister src `thenNat` \ register ->
2277 sz = primRepToSize pk
2278 dst__2 = amodeAddr amode
2280 code1 = amodeCode amode
2281 code2 = registerCode register tmp1
2283 src__2 = registerName register tmp1
2284 pk__2 = registerRep register
2285 sz__2 = primRepToSize pk__2
2287 code__2 = code1 `appOL` code2 `appOL`
2289 then unitOL (ST sz src__2 dst__2)
2290 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2294 -- Floating point assignment to a register/temporary
2295 -- Why is this so bizarrely ugly?
2296 assignReg_FltCode pk reg src
2297 = getRegisterReg reg `thenNat` \ register1 ->
2298 getRegister src `thenNat` \ register2 ->
2300 pk__2 = registerRep register2
2301 sz__2 = primRepToSize pk__2
2303 getNewRegNCG pk__2 `thenNat` \ tmp ->
2305 sz = primRepToSize pk
2306 dst__2 = registerName register1 g0 -- must be Fixed
2307 reg__2 = if pk /= pk__2 then tmp else dst__2
2308 code = registerCode register2 reg__2
2309 src__2 = registerName register2 reg__2
2312 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2313 else if isFixed register2 then
2314 code `snocOL` FMOV sz src__2 dst__2
2320 #endif {- sparc_TARGET_ARCH -}
2322 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2325 %************************************************************************
2327 \subsection{Generating an unconditional branch}
2329 %************************************************************************
2331 We accept two types of targets: an immediate CLabel or a tree that
2332 gets evaluated into a register. Any CLabels which are AsmTemporaries
2333 are assumed to be in the local block of code, close enough for a
2334 branch instruction. Other CLabels are assumed to be far away.
2336 (If applicable) Do not fill the delay slots here; you will confuse the
2340 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2342 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2344 #if alpha_TARGET_ARCH
2346 genJump (StCLbl lbl)
2347 | isAsmTemp lbl = returnInstr (BR target)
2348 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2350 target = ImmCLbl lbl
2353 = getRegister tree `thenNat` \ register ->
2354 getNewRegNCG PtrRep `thenNat` \ tmp ->
2356 dst = registerName register pv
2357 code = registerCode register pv
2358 target = registerName register pv
2360 if isFixed register then
2361 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2363 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2365 #endif {- alpha_TARGET_ARCH -}
2367 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2369 #if i386_TARGET_ARCH
2371 genJump dsts (StInd pk mem)
2372 = getAmode mem `thenNat` \ amode ->
2374 code = amodeCode amode
2375 target = amodeAddr amode
2377 returnNat (code `snocOL` JMP dsts (OpAddr target))
2381 = returnNat (unitOL (JMP dsts (OpImm target)))
2384 = getRegister tree `thenNat` \ register ->
2385 getNewRegNCG PtrRep `thenNat` \ tmp ->
2387 code = registerCode register tmp
2388 target = registerName register tmp
2390 returnNat (code `snocOL` JMP dsts (OpReg target))
2393 target = case imm of Just x -> x
2395 #endif {- i386_TARGET_ARCH -}
2397 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2399 #if sparc_TARGET_ARCH
2401 genJump dsts (StCLbl lbl)
2402 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2403 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2404 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2406 target = ImmCLbl lbl
2409 = getRegister tree `thenNat` \ register ->
2410 getNewRegNCG PtrRep `thenNat` \ tmp ->
2412 code = registerCode register tmp
2413 target = registerName register tmp
2415 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2417 #endif {- sparc_TARGET_ARCH -}
2419 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2422 %************************************************************************
2424 \subsection{Conditional jumps}
2426 %************************************************************************
2428 Conditional jumps are always to local labels, so we can use branch
2429 instructions. We peek at the arguments to decide what kind of
2432 ALPHA: For comparisons with 0, we're laughing, because we can just do
2433 the desired conditional branch.
2435 I386: First, we have to ensure that the condition
2436 codes are set according to the supplied comparison operation.
2438 SPARC: First, we have to ensure that the condition codes are set
2439 according to the supplied comparison operation. We generate slightly
2440 different code for floating point comparisons, because a floating
2441 point operation cannot directly precede a @BF@. We assume the worst
2442 and fill that slot with a @NOP@.
2444 SPARC: Do not fill the delay slots here; you will confuse the register
2449 :: CLabel -- the branch target
2450 -> StixExpr -- the condition on which to branch
2453 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2455 #if alpha_TARGET_ARCH
2457 genCondJump lbl (StPrim op [x, StInt 0])
2458 = getRegister x `thenNat` \ register ->
2459 getNewRegNCG (registerRep register)
2462 code = registerCode register tmp
2463 value = registerName register tmp
2464 pk = registerRep register
2465 target = ImmCLbl lbl
2467 returnSeq code [BI (cmpOp op) value target]
2469 cmpOp CharGtOp = GTT
2471 cmpOp CharEqOp = EQQ
2473 cmpOp CharLtOp = LTT
2482 cmpOp WordGeOp = ALWAYS
2483 cmpOp WordEqOp = EQQ
2485 cmpOp WordLtOp = NEVER
2486 cmpOp WordLeOp = EQQ
2488 cmpOp AddrGeOp = ALWAYS
2489 cmpOp AddrEqOp = EQQ
2491 cmpOp AddrLtOp = NEVER
2492 cmpOp AddrLeOp = EQQ
2494 genCondJump lbl (StPrim op [x, StDouble 0.0])
2495 = getRegister x `thenNat` \ register ->
2496 getNewRegNCG (registerRep register)
2499 code = registerCode register tmp
2500 value = registerName register tmp
2501 pk = registerRep register
2502 target = ImmCLbl lbl
2504 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2506 cmpOp FloatGtOp = GTT
2507 cmpOp FloatGeOp = GE
2508 cmpOp FloatEqOp = EQQ
2509 cmpOp FloatNeOp = NE
2510 cmpOp FloatLtOp = LTT
2511 cmpOp FloatLeOp = LE
2512 cmpOp DoubleGtOp = GTT
2513 cmpOp DoubleGeOp = GE
2514 cmpOp DoubleEqOp = EQQ
2515 cmpOp DoubleNeOp = NE
2516 cmpOp DoubleLtOp = LTT
2517 cmpOp DoubleLeOp = LE
2519 genCondJump lbl (StPrim op [x, y])
2521 = trivialFCode pr instr x y `thenNat` \ register ->
2522 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2524 code = registerCode register tmp
2525 result = registerName register tmp
2526 target = ImmCLbl lbl
2528 returnNat (code . mkSeqInstr (BF cond result target))
2530 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2532 fltCmpOp op = case op of
2546 (instr, cond) = case op of
2547 FloatGtOp -> (FCMP TF LE, EQQ)
2548 FloatGeOp -> (FCMP TF LTT, EQQ)
2549 FloatEqOp -> (FCMP TF EQQ, NE)
2550 FloatNeOp -> (FCMP TF EQQ, EQQ)
2551 FloatLtOp -> (FCMP TF LTT, NE)
2552 FloatLeOp -> (FCMP TF LE, NE)
2553 DoubleGtOp -> (FCMP TF LE, EQQ)
2554 DoubleGeOp -> (FCMP TF LTT, EQQ)
2555 DoubleEqOp -> (FCMP TF EQQ, NE)
2556 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2557 DoubleLtOp -> (FCMP TF LTT, NE)
2558 DoubleLeOp -> (FCMP TF LE, NE)
2560 genCondJump lbl (StPrim op [x, y])
2561 = trivialCode instr x y `thenNat` \ register ->
2562 getNewRegNCG IntRep `thenNat` \ tmp ->
2564 code = registerCode register tmp
2565 result = registerName register tmp
2566 target = ImmCLbl lbl
2568 returnNat (code . mkSeqInstr (BI cond result target))
2570 (instr, cond) = case op of
2571 CharGtOp -> (CMP LE, EQQ)
2572 CharGeOp -> (CMP LTT, EQQ)
2573 CharEqOp -> (CMP EQQ, NE)
2574 CharNeOp -> (CMP EQQ, EQQ)
2575 CharLtOp -> (CMP LTT, NE)
2576 CharLeOp -> (CMP LE, NE)
2577 IntGtOp -> (CMP LE, EQQ)
2578 IntGeOp -> (CMP LTT, EQQ)
2579 IntEqOp -> (CMP EQQ, NE)
2580 IntNeOp -> (CMP EQQ, EQQ)
2581 IntLtOp -> (CMP LTT, NE)
2582 IntLeOp -> (CMP LE, NE)
2583 WordGtOp -> (CMP ULE, EQQ)
2584 WordGeOp -> (CMP ULT, EQQ)
2585 WordEqOp -> (CMP EQQ, NE)
2586 WordNeOp -> (CMP EQQ, EQQ)
2587 WordLtOp -> (CMP ULT, NE)
2588 WordLeOp -> (CMP ULE, NE)
2589 AddrGtOp -> (CMP ULE, EQQ)
2590 AddrGeOp -> (CMP ULT, EQQ)
2591 AddrEqOp -> (CMP EQQ, NE)
2592 AddrNeOp -> (CMP EQQ, EQQ)
2593 AddrLtOp -> (CMP ULT, NE)
2594 AddrLeOp -> (CMP ULE, NE)
2596 #endif {- alpha_TARGET_ARCH -}
2598 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2600 #if i386_TARGET_ARCH
2602 genCondJump lbl bool
2603 = getCondCode bool `thenNat` \ condition ->
2605 code = condCode condition
2606 cond = condName condition
2608 returnNat (code `snocOL` JXX cond lbl)
2610 #endif {- i386_TARGET_ARCH -}
2612 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2614 #if sparc_TARGET_ARCH
2616 genCondJump lbl bool
2617 = getCondCode bool `thenNat` \ condition ->
2619 code = condCode condition
2620 cond = condName condition
2621 target = ImmCLbl lbl
2626 if condFloat condition
2627 then [NOP, BF cond False target, NOP]
2628 else [BI cond False target, NOP]
2632 #endif {- sparc_TARGET_ARCH -}
2634 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2637 %************************************************************************
2639 \subsection{Generating C calls}
2641 %************************************************************************
2643 Now the biggest nightmare---calls. Most of the nastiness is buried in
2644 @get_arg@, which moves the arguments to the correct registers/stack
2645 locations. Apart from that, the code is easy.
2647 (If applicable) Do not fill the delay slots here; you will confuse the
2652 :: FAST_STRING -- function to call
2654 -> PrimRep -- type of the result
2655 -> [StixExpr] -- arguments (of mixed type)
2658 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2660 #if alpha_TARGET_ARCH
2662 genCCall fn cconv kind args
2663 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2664 `thenNat` \ ((unused,_), argCode) ->
2666 nRegs = length allArgRegs - length unused
2667 code = asmSeqThen (map ($ []) argCode)
2670 LDA pv (AddrImm (ImmLab (ptext fn))),
2671 JSR ra (AddrReg pv) nRegs,
2672 LDGP gp (AddrReg ra)]
2674 ------------------------
2675 {- Try to get a value into a specific register (or registers) for
2676 a call. The first 6 arguments go into the appropriate
2677 argument register (separate registers for integer and floating
2678 point arguments, but used in lock-step), and the remaining
2679 arguments are dumped to the stack, beginning at 0(sp). Our
2680 first argument is a pair of the list of remaining argument
2681 registers to be assigned for this call and the next stack
2682 offset to use for overflowing arguments. This way,
2683 @get_Arg@ can be applied to all of a call's arguments using
2687 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2688 -> StixTree -- Current argument
2689 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2691 -- We have to use up all of our argument registers first...
2693 get_arg ((iDst,fDst):dsts, offset) arg
2694 = getRegister arg `thenNat` \ register ->
2696 reg = if isFloatingRep pk then fDst else iDst
2697 code = registerCode register reg
2698 src = registerName register reg
2699 pk = registerRep register
2702 if isFloatingRep pk then
2703 ((dsts, offset), if isFixed register then
2704 code . mkSeqInstr (FMOV src fDst)
2707 ((dsts, offset), if isFixed register then
2708 code . mkSeqInstr (OR src (RIReg src) iDst)
2711 -- Once we have run out of argument registers, we move to the
2714 get_arg ([], offset) arg
2715 = getRegister arg `thenNat` \ register ->
2716 getNewRegNCG (registerRep register)
2719 code = registerCode register tmp
2720 src = registerName register tmp
2721 pk = registerRep register
2722 sz = primRepToSize pk
2724 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2726 #endif {- alpha_TARGET_ARCH -}
2728 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2730 #if i386_TARGET_ARCH
2732 genCCall fn cconv ret_rep [StInt i]
2733 | fn == SLIT ("PerformGC_wrapper")
2735 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2736 CALL (ImmLit (ptext (if underscorePrefix
2737 then (SLIT ("_PerformGC_wrapper"))
2738 else (SLIT ("PerformGC_wrapper")))))
2744 genCCall fn cconv ret_rep args
2746 (reverse args) `thenNat` \ sizes_n_codes ->
2747 getDeltaNat `thenNat` \ delta ->
2748 let (sizes, codes) = unzip sizes_n_codes
2749 tot_arg_size = sum sizes
2750 code2 = concatOL codes
2752 [CALL (fn__2 tot_arg_size)]
2754 -- Deallocate parameters after call for ccall;
2755 -- but not for stdcall (callee does it)
2756 (if cconv == StdCallConv then [] else
2757 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2760 [DELTA (delta + tot_arg_size)]
2763 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2764 returnNat (code2 `appOL` call)
2767 -- function names that begin with '.' are assumed to be special
2768 -- internally generated names like '.mul,' which don't get an
2769 -- underscore prefix
2770 -- ToDo:needed (WDP 96/03) ???
2774 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2775 | otherwise -- General case
2776 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2778 stdcallsize tot_arg_size
2779 | cconv == StdCallConv = '@':show tot_arg_size
2787 push_arg :: StixExpr{-current argument-}
2788 -> NatM (Int, InstrBlock) -- argsz, code
2791 | is64BitRep arg_rep
2792 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2793 getDeltaNat `thenNat` \ delta ->
2794 setDeltaNat (delta - 8) `thenNat` \ _ ->
2795 let r_lo = VirtualRegI vr_lo
2796 r_hi = getHiVRegFromLo r_lo
2799 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2800 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2803 = get_op arg `thenNat` \ (code, reg, sz) ->
2804 getDeltaNat `thenNat` \ delta ->
2805 arg_size sz `bind` \ size ->
2806 setDeltaNat (delta-size) `thenNat` \ _ ->
2807 if (case sz of DF -> True; F -> True; _ -> False)
2808 then returnNat (size,
2810 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2812 GST sz reg (AddrBaseIndex (Just esp)
2816 else returnNat (size,
2818 PUSH L (OpReg reg) `snocOL`
2822 arg_rep = repOfStixExpr arg
2827 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2830 = getRegister op `thenNat` \ register ->
2831 getNewRegNCG (registerRep register)
2834 code = registerCode register tmp
2835 reg = registerName register tmp
2836 pk = registerRep register
2837 sz = primRepToSize pk
2839 returnNat (code, reg, sz)
2841 #endif {- i386_TARGET_ARCH -}
2843 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2845 #if sparc_TARGET_ARCH
2847 The SPARC calling convention is an absolute
2848 nightmare. The first 6x32 bits of arguments are mapped into
2849 %o0 through %o5, and the remaining arguments are dumped to the
2850 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2852 If we have to put args on the stack, move %o6==%sp down by
2853 the number of words to go on the stack, to ensure there's enough space.
2855 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2856 16 words above the stack pointer is a word for the address of
2857 a structure return value. I use this as a temporary location
2858 for moving values from float to int regs. Certainly it isn't
2859 safe to put anything in the 16 words starting at %sp, since
2860 this area can get trashed at any time due to window overflows
2861 caused by signal handlers.
2863 A final complication (if the above isn't enough) is that
2864 we can't blithely calculate the arguments one by one into
2865 %o0 .. %o5. Consider the following nested calls:
2869 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2870 the inner call will itself use %o0, which trashes the value put there
2871 in preparation for the outer call. Upshot: we need to calculate the
2872 args into temporary regs, and move those to arg regs or onto the
2873 stack only immediately prior to the call proper. Sigh.
2876 genCCall fn cconv kind args
2877 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2878 let (argcodes, vregss) = unzip argcode_and_vregs
2879 argcode = concatOL argcodes
2880 vregs = concat vregss
2881 n_argRegs = length allArgRegs
2882 n_argRegs_used = min (length vregs) n_argRegs
2883 (move_sp_down, move_sp_up)
2884 = let nn = length vregs - n_argRegs
2885 + 1 -- (for the road)
2888 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2890 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2892 = unitOL (CALL fn__2 n_argRegs_used False)
2894 returnNat (argcode `appOL`
2895 move_sp_down `appOL`
2896 transfer_code `appOL`
2901 -- function names that begin with '.' are assumed to be special
2902 -- internally generated names like '.mul,' which don't get an
2903 -- underscore prefix
2904 -- ToDo:needed (WDP 96/03) ???
2905 fn__2 = case (_HEAD_ fn) of
2906 '.' -> ImmLit (ptext fn)
2907 _ -> ImmLab False (ptext fn)
2909 -- move args from the integer vregs into which they have been
2910 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2911 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2913 move_final [] _ offset -- all args done
2916 move_final (v:vs) [] offset -- out of aregs; move to stack
2917 = ST W v (spRel offset)
2918 : move_final vs [] (offset+1)
2920 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2921 = OR False g0 (RIReg v) a
2922 : move_final vs az offset
2924 -- generate code to calculate an argument, and move it into one
2925 -- or two integer vregs.
2926 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2927 arg_to_int_vregs arg
2928 | is64BitRep (repOfStixExpr arg)
2929 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2930 let r_lo = VirtualRegI vr_lo
2931 r_hi = getHiVRegFromLo r_lo
2932 in returnNat (code, [r_hi, r_lo])
2934 = getRegister arg `thenNat` \ register ->
2935 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2936 let code = registerCode register tmp
2937 src = registerName register tmp
2938 pk = registerRep register
2940 -- the value is in src. Get it into 1 or 2 int vregs.
2943 getNewRegNCG WordRep `thenNat` \ v1 ->
2944 getNewRegNCG WordRep `thenNat` \ v2 ->
2947 FMOV DF src f0 `snocOL`
2948 ST F f0 (spRel 16) `snocOL`
2949 LD W (spRel 16) v1 `snocOL`
2950 ST F (fPair f0) (spRel 16) `snocOL`
2956 getNewRegNCG WordRep `thenNat` \ v1 ->
2959 ST F src (spRel 16) `snocOL`
2965 getNewRegNCG WordRep `thenNat` \ v1 ->
2967 code `snocOL` OR False g0 (RIReg src) v1
2971 #endif {- sparc_TARGET_ARCH -}
2973 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2976 %************************************************************************
2978 \subsection{Support bits}
2980 %************************************************************************
2982 %************************************************************************
2984 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2986 %************************************************************************
2988 Turn those condition codes into integers now (when they appear on
2989 the right hand side of an assignment).
2991 (If applicable) Do not fill the delay slots here; you will confuse the
2995 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2997 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2999 #if alpha_TARGET_ARCH
3000 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3001 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3002 #endif {- alpha_TARGET_ARCH -}
3004 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3006 #if i386_TARGET_ARCH
3009 = condIntCode cond x y `thenNat` \ condition ->
3010 getNewRegNCG IntRep `thenNat` \ tmp ->
3012 code = condCode condition
3013 cond = condName condition
3014 code__2 dst = code `appOL` toOL [
3015 SETCC cond (OpReg tmp),
3016 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3017 MOV L (OpReg tmp) (OpReg dst)]
3019 returnNat (Any IntRep code__2)
3022 = getNatLabelNCG `thenNat` \ lbl1 ->
3023 getNatLabelNCG `thenNat` \ lbl2 ->
3024 condFltCode cond x y `thenNat` \ condition ->
3026 code = condCode condition
3027 cond = condName condition
3028 code__2 dst = code `appOL` toOL [
3030 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3033 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3036 returnNat (Any IntRep code__2)
3038 #endif {- i386_TARGET_ARCH -}
3040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3042 #if sparc_TARGET_ARCH
3044 condIntReg EQQ x (StInt 0)
3045 = getRegister x `thenNat` \ register ->
3046 getNewRegNCG IntRep `thenNat` \ tmp ->
3048 code = registerCode register tmp
3049 src = registerName register tmp
3050 code__2 dst = code `appOL` toOL [
3051 SUB False True g0 (RIReg src) g0,
3052 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3054 returnNat (Any IntRep code__2)
3057 = getRegister x `thenNat` \ register1 ->
3058 getRegister y `thenNat` \ register2 ->
3059 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3060 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3062 code1 = registerCode register1 tmp1
3063 src1 = registerName register1 tmp1
3064 code2 = registerCode register2 tmp2
3065 src2 = registerName register2 tmp2
3066 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3067 XOR False src1 (RIReg src2) dst,
3068 SUB False True g0 (RIReg dst) g0,
3069 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3071 returnNat (Any IntRep code__2)
3073 condIntReg NE x (StInt 0)
3074 = getRegister x `thenNat` \ register ->
3075 getNewRegNCG IntRep `thenNat` \ tmp ->
3077 code = registerCode register tmp
3078 src = registerName register tmp
3079 code__2 dst = code `appOL` toOL [
3080 SUB False True g0 (RIReg src) g0,
3081 ADD True False g0 (RIImm (ImmInt 0)) dst]
3083 returnNat (Any IntRep code__2)
3086 = getRegister x `thenNat` \ register1 ->
3087 getRegister y `thenNat` \ register2 ->
3088 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3089 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3091 code1 = registerCode register1 tmp1
3092 src1 = registerName register1 tmp1
3093 code2 = registerCode register2 tmp2
3094 src2 = registerName register2 tmp2
3095 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3096 XOR False src1 (RIReg src2) dst,
3097 SUB False True g0 (RIReg dst) g0,
3098 ADD True False g0 (RIImm (ImmInt 0)) dst]
3100 returnNat (Any IntRep code__2)
3103 = getNatLabelNCG `thenNat` \ lbl1 ->
3104 getNatLabelNCG `thenNat` \ lbl2 ->
3105 condIntCode cond x y `thenNat` \ condition ->
3107 code = condCode condition
3108 cond = condName condition
3109 code__2 dst = code `appOL` toOL [
3110 BI cond False (ImmCLbl lbl1), NOP,
3111 OR False g0 (RIImm (ImmInt 0)) dst,
3112 BI ALWAYS False (ImmCLbl lbl2), NOP,
3114 OR False g0 (RIImm (ImmInt 1)) dst,
3117 returnNat (Any IntRep code__2)
3120 = getNatLabelNCG `thenNat` \ lbl1 ->
3121 getNatLabelNCG `thenNat` \ lbl2 ->
3122 condFltCode cond x y `thenNat` \ condition ->
3124 code = condCode condition
3125 cond = condName condition
3126 code__2 dst = code `appOL` toOL [
3128 BF cond False (ImmCLbl lbl1), NOP,
3129 OR False g0 (RIImm (ImmInt 0)) dst,
3130 BI ALWAYS False (ImmCLbl lbl2), NOP,
3132 OR False g0 (RIImm (ImmInt 1)) dst,
3135 returnNat (Any IntRep code__2)
3137 #endif {- sparc_TARGET_ARCH -}
3139 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3142 %************************************************************************
3144 \subsubsection{@trivial*Code@: deal with trivial instructions}
3146 %************************************************************************
3148 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3149 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3150 for constants on the right hand side, because that's where the generic
3151 optimizer will have put them.
3153 Similarly, for unary instructions, we don't have to worry about
3154 matching an StInt as the argument, because genericOpt will already
3155 have handled the constant-folding.
3159 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3160 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3161 -> Maybe (Operand -> Operand -> Instr)
3162 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3164 -> StixExpr -> StixExpr -- the two arguments
3169 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3170 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3171 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3173 -> StixExpr -> StixExpr -- the two arguments
3177 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3178 ,IF_ARCH_i386 ((Operand -> Instr)
3179 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3181 -> StixExpr -- the one argument
3186 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3187 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3188 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3190 -> StixExpr -- the one argument
3193 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3195 #if alpha_TARGET_ARCH
3197 trivialCode instr x (StInt y)
3199 = getRegister x `thenNat` \ register ->
3200 getNewRegNCG IntRep `thenNat` \ tmp ->
3202 code = registerCode register tmp
3203 src1 = registerName register tmp
3204 src2 = ImmInt (fromInteger y)
3205 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3207 returnNat (Any IntRep code__2)
3209 trivialCode instr x y
3210 = getRegister x `thenNat` \ register1 ->
3211 getRegister y `thenNat` \ register2 ->
3212 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3213 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3215 code1 = registerCode register1 tmp1 []
3216 src1 = registerName register1 tmp1
3217 code2 = registerCode register2 tmp2 []
3218 src2 = registerName register2 tmp2
3219 code__2 dst = asmSeqThen [code1, code2] .
3220 mkSeqInstr (instr src1 (RIReg src2) dst)
3222 returnNat (Any IntRep code__2)
3225 trivialUCode instr x
3226 = getRegister x `thenNat` \ register ->
3227 getNewRegNCG IntRep `thenNat` \ tmp ->
3229 code = registerCode register tmp
3230 src = registerName register tmp
3231 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3233 returnNat (Any IntRep code__2)
3236 trivialFCode _ instr x y
3237 = getRegister x `thenNat` \ register1 ->
3238 getRegister y `thenNat` \ register2 ->
3239 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3240 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3242 code1 = registerCode register1 tmp1
3243 src1 = registerName register1 tmp1
3245 code2 = registerCode register2 tmp2
3246 src2 = registerName register2 tmp2
3248 code__2 dst = asmSeqThen [code1 [], code2 []] .
3249 mkSeqInstr (instr src1 src2 dst)
3251 returnNat (Any DoubleRep code__2)
3253 trivialUFCode _ instr x
3254 = getRegister x `thenNat` \ register ->
3255 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3257 code = registerCode register tmp
3258 src = registerName register tmp
3259 code__2 dst = code . mkSeqInstr (instr src dst)
3261 returnNat (Any DoubleRep code__2)
3263 #endif {- alpha_TARGET_ARCH -}
3265 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3267 #if i386_TARGET_ARCH
3269 The Rules of the Game are:
3271 * You cannot assume anything about the destination register dst;
3272 it may be anything, including a fixed reg.
3274 * You may compute an operand into a fixed reg, but you may not
3275 subsequently change the contents of that fixed reg. If you
3276 want to do so, first copy the value either to a temporary
3277 or into dst. You are free to modify dst even if it happens
3278 to be a fixed reg -- that's not your problem.
3280 * You cannot assume that a fixed reg will stay live over an
3281 arbitrary computation. The same applies to the dst reg.
3283 * Temporary regs obtained from getNewRegNCG are distinct from
3284 each other and from all other regs, and stay live over
3285 arbitrary computations.
3289 trivialCode instr maybe_revinstr a b
3292 = getRegister a `thenNat` \ rega ->
3295 then registerCode rega dst `bind` \ code_a ->
3297 instr (OpImm imm_b) (OpReg dst)
3298 else registerCodeF rega `bind` \ code_a ->
3299 registerNameF rega `bind` \ r_a ->
3301 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3302 instr (OpImm imm_b) (OpReg dst)
3304 returnNat (Any IntRep mkcode)
3307 = getRegister b `thenNat` \ regb ->
3308 getNewRegNCG IntRep `thenNat` \ tmp ->
3309 let revinstr_avail = maybeToBool maybe_revinstr
3310 revinstr = case maybe_revinstr of Just ri -> ri
3314 then registerCode regb dst `bind` \ code_b ->
3316 revinstr (OpImm imm_a) (OpReg dst)
3317 else registerCodeF regb `bind` \ code_b ->
3318 registerNameF regb `bind` \ r_b ->
3320 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3321 revinstr (OpImm imm_a) (OpReg dst)
3325 then registerCode regb tmp `bind` \ code_b ->
3327 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3328 instr (OpReg tmp) (OpReg dst)
3329 else registerCodeF regb `bind` \ code_b ->
3330 registerNameF regb `bind` \ r_b ->
3332 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3333 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3334 instr (OpReg tmp) (OpReg dst)
3336 returnNat (Any IntRep mkcode)
3339 = getRegister a `thenNat` \ rega ->
3340 getRegister b `thenNat` \ regb ->
3341 getNewRegNCG IntRep `thenNat` \ tmp ->
3343 = case (isAny rega, isAny regb) of
3345 -> registerCode regb tmp `bind` \ code_b ->
3346 registerCode rega dst `bind` \ code_a ->
3349 instr (OpReg tmp) (OpReg dst)
3351 -> registerCode rega tmp `bind` \ code_a ->
3352 registerCodeF regb `bind` \ code_b ->
3353 registerNameF regb `bind` \ r_b ->
3356 instr (OpReg r_b) (OpReg tmp) `snocOL`
3357 MOV L (OpReg tmp) (OpReg dst)
3359 -> registerCode regb tmp `bind` \ code_b ->
3360 registerCodeF rega `bind` \ code_a ->
3361 registerNameF rega `bind` \ r_a ->
3364 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3365 instr (OpReg tmp) (OpReg dst)
3367 -> registerCodeF rega `bind` \ code_a ->
3368 registerNameF rega `bind` \ r_a ->
3369 registerCodeF regb `bind` \ code_b ->
3370 registerNameF regb `bind` \ r_b ->
3372 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3374 instr (OpReg r_b) (OpReg tmp) `snocOL`
3375 MOV L (OpReg tmp) (OpReg dst)
3377 returnNat (Any IntRep mkcode)
3380 maybe_imm_a = maybeImm a
3381 is_imm_a = maybeToBool maybe_imm_a
3382 imm_a = case maybe_imm_a of Just imm -> imm
3384 maybe_imm_b = maybeImm b
3385 is_imm_b = maybeToBool maybe_imm_b
3386 imm_b = case maybe_imm_b of Just imm -> imm
3390 trivialUCode instr x
3391 = getRegister x `thenNat` \ register ->
3393 code__2 dst = let code = registerCode register dst
3394 src = registerName register dst
3396 if isFixed register && dst /= src
3397 then toOL [MOV L (OpReg src) (OpReg dst),
3399 else unitOL (instr (OpReg src))
3401 returnNat (Any IntRep code__2)
3404 trivialFCode pk instr x y
3405 = getRegister x `thenNat` \ register1 ->
3406 getRegister y `thenNat` \ register2 ->
3407 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3408 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3410 code1 = registerCode register1 tmp1
3411 src1 = registerName register1 tmp1
3413 code2 = registerCode register2 tmp2
3414 src2 = registerName register2 tmp2
3417 -- treat the common case specially: both operands in
3419 | isAny register1 && isAny register2
3422 instr (primRepToSize pk) src1 src2 dst
3424 -- be paranoid (and inefficient)
3426 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3428 instr (primRepToSize pk) tmp1 src2 dst
3430 returnNat (Any pk code__2)
3434 trivialUFCode pk instr x
3435 = getRegister x `thenNat` \ register ->
3436 getNewRegNCG pk `thenNat` \ tmp ->
3438 code = registerCode register tmp
3439 src = registerName register tmp
3440 code__2 dst = code `snocOL` instr src dst
3442 returnNat (Any pk code__2)
3444 #endif {- i386_TARGET_ARCH -}
3446 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3448 #if sparc_TARGET_ARCH
3450 trivialCode instr x (StInt y)
3452 = getRegister x `thenNat` \ register ->
3453 getNewRegNCG IntRep `thenNat` \ tmp ->
3455 code = registerCode register tmp
3456 src1 = registerName register tmp
3457 src2 = ImmInt (fromInteger y)
3458 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3460 returnNat (Any IntRep code__2)
3462 trivialCode instr x y
3463 = getRegister x `thenNat` \ register1 ->
3464 getRegister y `thenNat` \ register2 ->
3465 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3466 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3468 code1 = registerCode register1 tmp1
3469 src1 = registerName register1 tmp1
3470 code2 = registerCode register2 tmp2
3471 src2 = registerName register2 tmp2
3472 code__2 dst = code1 `appOL` code2 `snocOL`
3473 instr src1 (RIReg src2) dst
3475 returnNat (Any IntRep code__2)
3478 trivialFCode pk instr x y
3479 = getRegister x `thenNat` \ register1 ->
3480 getRegister y `thenNat` \ register2 ->
3481 getNewRegNCG (registerRep register1)
3483 getNewRegNCG (registerRep register2)
3485 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3487 promote x = FxTOy F DF x tmp
3489 pk1 = registerRep register1
3490 code1 = registerCode register1 tmp1
3491 src1 = registerName register1 tmp1
3493 pk2 = registerRep register2
3494 code2 = registerCode register2 tmp2
3495 src2 = registerName register2 tmp2
3499 code1 `appOL` code2 `snocOL`
3500 instr (primRepToSize pk) src1 src2 dst
3501 else if pk1 == FloatRep then
3502 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3503 instr DF tmp src2 dst
3505 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3506 instr DF src1 tmp dst
3508 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3511 trivialUCode instr x
3512 = getRegister x `thenNat` \ register ->
3513 getNewRegNCG IntRep `thenNat` \ tmp ->
3515 code = registerCode register tmp
3516 src = registerName register tmp
3517 code__2 dst = code `snocOL` instr (RIReg src) dst
3519 returnNat (Any IntRep code__2)
3522 trivialUFCode pk instr x
3523 = getRegister x `thenNat` \ register ->
3524 getNewRegNCG pk `thenNat` \ tmp ->
3526 code = registerCode register tmp
3527 src = registerName register tmp
3528 code__2 dst = code `snocOL` instr src dst
3530 returnNat (Any pk code__2)
3532 #endif {- sparc_TARGET_ARCH -}
3534 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3537 %************************************************************************
3539 \subsubsection{Coercing to/from integer/floating-point...}
3541 %************************************************************************
3543 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3544 conversions. We have to store temporaries in memory to move
3545 between the integer and the floating point register sets.
3547 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3548 pretend, on sparc at least, that double and float regs are seperate
3549 kinds, so the value has to be computed into one kind before being
3550 explicitly "converted" to live in the other kind.
3553 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3554 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3556 coerceDbl2Flt :: StixExpr -> NatM Register
3557 coerceFlt2Dbl :: StixExpr -> NatM Register
3561 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3563 #if alpha_TARGET_ARCH
3566 = getRegister x `thenNat` \ register ->
3567 getNewRegNCG IntRep `thenNat` \ reg ->
3569 code = registerCode register reg
3570 src = registerName register reg
3572 code__2 dst = code . mkSeqInstrs [
3574 LD TF dst (spRel 0),
3577 returnNat (Any DoubleRep code__2)
3581 = getRegister x `thenNat` \ register ->
3582 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3584 code = registerCode register tmp
3585 src = registerName register tmp
3587 code__2 dst = code . mkSeqInstrs [
3589 ST TF tmp (spRel 0),
3592 returnNat (Any IntRep code__2)
3594 #endif {- alpha_TARGET_ARCH -}
3596 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3598 #if i386_TARGET_ARCH
3601 = getRegister x `thenNat` \ register ->
3602 getNewRegNCG IntRep `thenNat` \ reg ->
3604 code = registerCode register reg
3605 src = registerName register reg
3606 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3607 code__2 dst = code `snocOL` opc src dst
3609 returnNat (Any pk code__2)
3612 coerceFP2Int fprep x
3613 = getRegister x `thenNat` \ register ->
3614 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3616 code = registerCode register tmp
3617 src = registerName register tmp
3618 pk = registerRep register
3620 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3621 code__2 dst = code `snocOL` opc src dst
3623 returnNat (Any IntRep code__2)
3626 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3627 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3629 #endif {- i386_TARGET_ARCH -}
3631 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3633 #if sparc_TARGET_ARCH
3636 = getRegister x `thenNat` \ register ->
3637 getNewRegNCG IntRep `thenNat` \ reg ->
3639 code = registerCode register reg
3640 src = registerName register reg
3642 code__2 dst = code `appOL` toOL [
3643 ST W src (spRel (-2)),
3644 LD W (spRel (-2)) dst,
3645 FxTOy W (primRepToSize pk) dst dst]
3647 returnNat (Any pk code__2)
3650 coerceFP2Int fprep x
3651 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3652 getRegister x `thenNat` \ register ->
3653 getNewRegNCG fprep `thenNat` \ reg ->
3654 getNewRegNCG FloatRep `thenNat` \ tmp ->
3656 code = registerCode register reg
3657 src = registerName register reg
3658 code__2 dst = code `appOL` toOL [
3659 FxTOy (primRepToSize fprep) W src tmp,
3660 ST W tmp (spRel (-2)),
3661 LD W (spRel (-2)) dst]
3663 returnNat (Any IntRep code__2)
3667 = getRegister x `thenNat` \ register ->
3668 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3669 let code = registerCode register tmp
3670 src = registerName register tmp
3672 returnNat (Any FloatRep
3673 (\dst -> code `snocOL` FxTOy DF F src dst))
3677 = getRegister x `thenNat` \ register ->
3678 getNewRegNCG FloatRep `thenNat` \ tmp ->
3679 let code = registerCode register tmp
3680 src = registerName register tmp
3682 returnNat (Any DoubleRep
3683 (\dst -> code `snocOL` FxTOy F DF src dst))
3685 #endif {- sparc_TARGET_ARCH -}
3687 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -