2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import Unique ( Unique )
18 import MachMisc -- may differ per-platform
20 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
21 snocOL, consOL, concatOL )
22 import MachOp ( MachOp(..), pprMachOp )
23 import AbsCUtils ( magicIdPrimRep )
24 import PprAbsC ( pprMagicId )
25 import ForeignCall ( CCallConv(..) )
26 import CLabel ( CLabel, labelDynamic )
27 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
28 import CLabel ( isAsmTemp )
30 import Maybes ( maybeToBool )
31 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
32 getPrimRepSizeInBytes )
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 Outputable ( assertPanic )
53 import TRACE ( trace )
58 @InstrBlock@s are the insn sequences generated by the insn selectors.
59 They are really trees of insns to facilitate fast appending, where a
60 left-to-right traversal (pre-order?) yields the insns in the correct
64 type InstrBlock = OrdList Instr
68 isLeft (Left _) = True
69 isLeft (Right _) = False
74 Code extractor for an entire stix tree---stix statement level.
77 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
79 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
80 returnNat (concatOL instrss)
83 stmtToInstrs :: StixStmt -> NatM InstrBlock
84 stmtToInstrs stmt = case stmt of
85 StComment s -> returnNat (unitOL (COMMENT s))
86 StSegment seg -> returnNat (unitOL (SEGMENT seg))
88 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
90 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
93 StLabel lab -> returnNat (unitOL (LABEL lab))
95 StJump dsts arg -> genJump dsts (derefDLL arg)
96 StCondJump lab arg -> genCondJump lab (derefDLL arg)
98 -- A call returning void, ie one done for its side-effects. Note
99 -- that this is the only StVoidable we handle.
100 StVoidable (StCall fn cconv VoidRep args)
101 -> genCCall fn cconv VoidRep (map derefDLL args)
103 StAssignMem pk addr src
104 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
105 | ncg_target_is_32bit
106 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
107 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
108 StAssignReg pk reg src
109 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
110 | ncg_target_is_32bit
111 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
112 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
115 -- When falling through on the Alpha, we still have to load pv
116 -- with the address of the next routine, so that it can load gp.
117 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
121 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
122 returnNat (DATA (primRepToSize kind) imms
123 `consOL` concatOL codes)
125 getData :: StixExpr -> NatM (InstrBlock, Imm)
126 getData (StInt i) = returnNat (nilOL, ImmInteger i)
127 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
128 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
129 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
130 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
131 -- the linker can handle simple arithmetic...
132 getData (StIndex rep (StCLbl lbl) (StInt off)) =
134 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
136 -- Top-level lifted-out string. The segment will already have been set
137 -- (see Stix.liftStrings).
139 -> returnNat (unitOL (ASCII True (unpackFS str)))
142 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
145 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
146 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
147 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
149 derefDLL :: StixExpr -> StixExpr
151 | opt_Static -- short out the entire deal if not doing DLLs
158 StCLbl lbl -> if labelDynamic lbl
159 then StInd PtrRep (StCLbl lbl)
161 -- all the rest are boring
162 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
163 StMachOp mop args -> StMachOp mop (map qq args)
164 StInd pk addr -> StInd pk (qq addr)
165 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
166 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
172 _ -> pprPanic "derefDLL: unhandled case"
176 %************************************************************************
178 \subsection{General things for putting together code sequences}
180 %************************************************************************
183 mangleIndexTree :: StixExpr -> StixExpr
185 mangleIndexTree (StIndex pk base (StInt i))
186 = StMachOp MO_Nat_Add [base, off]
188 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
190 mangleIndexTree (StIndex pk base off)
191 = StMachOp MO_Nat_Add [
194 in if s == 0 then off
195 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
198 shift :: PrimRep -> Int
199 shift rep = case getPrimRepSizeInBytes rep of
204 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
205 (Outputable.int other)
209 maybeImm :: StixExpr -> Maybe Imm
213 maybeImm (StIndex rep (StCLbl l) (StInt off))
214 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
216 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
217 = Just (ImmInt (fromInteger i))
219 = Just (ImmInteger i)
224 %************************************************************************
226 \subsection{The @Register64@ type}
228 %************************************************************************
230 Simple support for generating 64-bit code (ie, 64 bit values and 64
231 bit assignments) on 32-bit platforms. Unlike the main code generator
232 we merely shoot for generating working code as simply as possible, and
233 pay little attention to code quality. Specifically, there is no
234 attempt to deal cleverly with the fixed-vs-floating register
235 distinction; all values are generated into (pairs of) floating
236 registers, even if this would mean some redundant reg-reg moves as a
237 result. Only one of the VRegUniques is returned, since it will be
238 of the VRegUniqueLo form, and the upper-half VReg can be determined
239 by applying getHiVRegFromLo to it.
243 data ChildCode64 -- a.k.a "Register64"
246 VRegUnique -- unique for the lower 32-bit temporary
247 -- which contains the result; use getHiVRegFromLo to find
248 -- the other VRegUnique.
249 -- Rules of this simplified insn selection game are
250 -- therefore that the returned VRegUnique may be modified
252 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
253 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
254 iselExpr64 :: StixExpr -> NatM ChildCode64
256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
260 assignMem_I64Code addrTree valueTree
261 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
262 getRegister addrTree `thenNat` \ register_addr ->
263 getNewRegNCG IntRep `thenNat` \ t_addr ->
264 let rlo = VirtualRegI vrlo
265 rhi = getHiVRegFromLo rlo
266 code_addr = registerCode register_addr t_addr
267 reg_addr = registerName register_addr t_addr
268 -- Little-endian store
269 mov_lo = MOV L (OpReg rlo)
270 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
271 mov_hi = MOV L (OpReg rhi)
272 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
274 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
276 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
277 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
279 r_dst_lo = mkVReg u_dst IntRep
280 r_src_lo = VirtualRegI vr_src_lo
281 r_dst_hi = getHiVRegFromLo r_dst_lo
282 r_src_hi = getHiVRegFromLo r_src_lo
283 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
284 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
287 vcode `snocOL` mov_lo `snocOL` mov_hi
290 assignReg_I64Code lvalue valueTree
291 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
296 iselExpr64 (StInd pk addrTree)
298 = getRegister addrTree `thenNat` \ register_addr ->
299 getNewRegNCG IntRep `thenNat` \ t_addr ->
300 getNewRegNCG IntRep `thenNat` \ rlo ->
301 let rhi = getHiVRegFromLo rlo
302 code_addr = registerCode register_addr t_addr
303 reg_addr = registerName register_addr t_addr
304 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
306 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
310 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
314 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
316 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
317 let r_dst_hi = getHiVRegFromLo r_dst_lo
318 r_src_lo = mkVReg vu IntRep
319 r_src_hi = getHiVRegFromLo r_src_lo
320 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
321 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
324 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
327 iselExpr64 (StCall fn cconv kind args)
329 = genCCall fn cconv kind args `thenNat` \ call ->
330 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
331 let r_dst_hi = getHiVRegFromLo r_dst_lo
332 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
333 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
336 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
337 (getVRegUnique r_dst_lo)
341 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
343 #endif {- i386_TARGET_ARCH -}
345 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
347 #if sparc_TARGET_ARCH
349 assignMem_I64Code addrTree valueTree
350 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
351 getRegister addrTree `thenNat` \ register_addr ->
352 getNewRegNCG IntRep `thenNat` \ t_addr ->
353 let rlo = VirtualRegI vrlo
354 rhi = getHiVRegFromLo rlo
355 code_addr = registerCode register_addr t_addr
356 reg_addr = registerName register_addr t_addr
358 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
359 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
361 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
364 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
365 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
367 r_dst_lo = mkVReg u_dst IntRep
368 r_src_lo = VirtualRegI vr_src_lo
369 r_dst_hi = getHiVRegFromLo r_dst_lo
370 r_src_hi = getHiVRegFromLo r_src_lo
371 mov_lo = mkMOV r_src_lo r_dst_lo
372 mov_hi = mkMOV r_src_hi r_dst_hi
373 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
376 vcode `snocOL` mov_hi `snocOL` mov_lo
378 assignReg_I64Code lvalue valueTree
379 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
383 -- Don't delete this -- it's very handy for debugging.
385 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
386 -- = panic "iselExpr64(???)"
388 iselExpr64 (StInd pk addrTree)
390 = getRegister addrTree `thenNat` \ register_addr ->
391 getNewRegNCG IntRep `thenNat` \ t_addr ->
392 getNewRegNCG IntRep `thenNat` \ rlo ->
393 let rhi = getHiVRegFromLo rlo
394 code_addr = registerCode register_addr t_addr
395 reg_addr = registerName register_addr t_addr
396 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
397 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
400 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
404 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
406 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
407 let r_dst_hi = getHiVRegFromLo r_dst_lo
408 r_src_lo = mkVReg vu IntRep
409 r_src_hi = getHiVRegFromLo r_src_lo
410 mov_lo = mkMOV r_src_lo r_dst_lo
411 mov_hi = mkMOV r_src_hi r_dst_hi
412 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
415 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
418 iselExpr64 (StCall fn cconv kind args)
420 = genCCall fn cconv kind args `thenNat` \ call ->
421 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
422 let r_dst_hi = getHiVRegFromLo r_dst_lo
423 mov_lo = mkMOV o0 r_dst_lo
424 mov_hi = mkMOV o1 r_dst_hi
425 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
428 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
429 (getVRegUnique r_dst_lo)
433 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
435 #endif {- sparc_TARGET_ARCH -}
437 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
441 %************************************************************************
443 \subsection{The @Register@ type}
445 %************************************************************************
447 @Register@s passed up the tree. If the stix code forces the register
448 to live in a pre-decided machine register, it comes out as @Fixed@;
449 otherwise, it comes out as @Any@, and the parent can decide which
450 register to put it in.
454 = Fixed PrimRep Reg InstrBlock
455 | Any PrimRep (Reg -> InstrBlock)
457 registerCode :: Register -> Reg -> InstrBlock
458 registerCode (Fixed _ _ code) reg = code
459 registerCode (Any _ code) reg = code reg
461 registerCodeF (Fixed _ _ code) = code
462 registerCodeF (Any _ _) = panic "registerCodeF"
464 registerCodeA (Any _ code) = code
465 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
467 registerName :: Register -> Reg -> Reg
468 registerName (Fixed _ reg _) _ = reg
469 registerName (Any _ _) reg = reg
471 registerNameF (Fixed _ reg _) = reg
472 registerNameF (Any _ _) = panic "registerNameF"
474 registerRep :: Register -> PrimRep
475 registerRep (Fixed pk _ _) = pk
476 registerRep (Any pk _) = pk
478 swizzleRegisterRep :: Register -> PrimRep -> Register
479 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
480 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
482 {-# INLINE registerCode #-}
483 {-# INLINE registerCodeF #-}
484 {-# INLINE registerName #-}
485 {-# INLINE registerNameF #-}
486 {-# INLINE registerRep #-}
487 {-# INLINE isFixed #-}
490 isFixed, isAny :: Register -> Bool
491 isFixed (Fixed _ _ _) = True
492 isFixed (Any _ _) = False
494 isAny = not . isFixed
497 Generate code to get a subtree into a @Register@:
500 getRegisterReg :: StixReg -> NatM Register
501 getRegister :: StixExpr -> NatM Register
504 getRegisterReg (StixMagicId mid)
505 = case get_MagicId_reg_or_addr mid of
507 -> let pk = magicIdPrimRep mid
508 in returnNat (Fixed pk (RealReg rrno) nilOL)
510 -- By this stage, the only MagicIds remaining should be the
511 -- ones which map to a real machine register on this platform. Hence ...
512 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
514 getRegisterReg (StixTemp (StixVReg u pk))
515 = returnNat (Fixed pk (mkVReg u pk) nilOL)
519 -- Don't delete this -- it's very handy for debugging.
521 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
522 -- = panic "getRegister(???)"
524 getRegister (StReg reg)
527 getRegister tree@(StIndex _ _ _)
528 = getRegister (mangleIndexTree tree)
530 getRegister (StCall fn cconv kind args)
531 | not (ncg_target_is_32bit && is64BitRep kind)
532 = genCCall fn cconv kind args `thenNat` \ call ->
533 returnNat (Fixed kind reg call)
535 reg = if isFloatingRep kind
536 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
537 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
539 getRegister (StString s)
540 = getNatLabelNCG `thenNat` \ lbl ->
542 imm_lbl = ImmCLbl lbl
545 SEGMENT RoDataSegment,
547 ASCII True (unpackFS s),
549 #if alpha_TARGET_ARCH
550 LDA dst (AddrImm imm_lbl)
553 MOV L (OpImm imm_lbl) (OpReg dst)
555 #if sparc_TARGET_ARCH
556 SETHI (HI imm_lbl) dst,
557 OR False dst (RIImm (LO imm_lbl)) dst
561 returnNat (Any PtrRep code)
563 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
564 -- end of machine-"independent" bit; here we go on the rest...
566 #if alpha_TARGET_ARCH
568 getRegister (StDouble d)
569 = getNatLabelNCG `thenNat` \ lbl ->
570 getNewRegNCG PtrRep `thenNat` \ tmp ->
571 let code dst = mkSeqInstrs [
574 DATA TF [ImmLab (rational d)],
576 LDA tmp (AddrImm (ImmCLbl lbl)),
577 LD TF dst (AddrReg tmp)]
579 returnNat (Any DoubleRep code)
581 getRegister (StPrim primop [x]) -- unary PrimOps
583 IntNegOp -> trivialUCode (NEG Q False) x
585 NotOp -> trivialUCode NOT x
587 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
588 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
590 OrdOp -> coerceIntCode IntRep x
593 Float2IntOp -> coerceFP2Int x
594 Int2FloatOp -> coerceInt2FP pr x
595 Double2IntOp -> coerceFP2Int x
596 Int2DoubleOp -> coerceInt2FP pr x
598 Double2FloatOp -> coerceFltCode x
599 Float2DoubleOp -> coerceFltCode x
601 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
603 fn = case other_op of
604 FloatExpOp -> FSLIT("exp")
605 FloatLogOp -> FSLIT("log")
606 FloatSqrtOp -> FSLIT("sqrt")
607 FloatSinOp -> FSLIT("sin")
608 FloatCosOp -> FSLIT("cos")
609 FloatTanOp -> FSLIT("tan")
610 FloatAsinOp -> FSLIT("asin")
611 FloatAcosOp -> FSLIT("acos")
612 FloatAtanOp -> FSLIT("atan")
613 FloatSinhOp -> FSLIT("sinh")
614 FloatCoshOp -> FSLIT("cosh")
615 FloatTanhOp -> FSLIT("tanh")
616 DoubleExpOp -> FSLIT("exp")
617 DoubleLogOp -> FSLIT("log")
618 DoubleSqrtOp -> FSLIT("sqrt")
619 DoubleSinOp -> FSLIT("sin")
620 DoubleCosOp -> FSLIT("cos")
621 DoubleTanOp -> FSLIT("tan")
622 DoubleAsinOp -> FSLIT("asin")
623 DoubleAcosOp -> FSLIT("acos")
624 DoubleAtanOp -> FSLIT("atan")
625 DoubleSinhOp -> FSLIT("sinh")
626 DoubleCoshOp -> FSLIT("cosh")
627 DoubleTanhOp -> FSLIT("tanh")
629 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
631 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
633 CharGtOp -> trivialCode (CMP LTT) y x
634 CharGeOp -> trivialCode (CMP LE) y x
635 CharEqOp -> trivialCode (CMP EQQ) x y
636 CharNeOp -> int_NE_code x y
637 CharLtOp -> trivialCode (CMP LTT) x y
638 CharLeOp -> trivialCode (CMP LE) x y
640 IntGtOp -> trivialCode (CMP LTT) y x
641 IntGeOp -> trivialCode (CMP LE) y x
642 IntEqOp -> trivialCode (CMP EQQ) x y
643 IntNeOp -> int_NE_code x y
644 IntLtOp -> trivialCode (CMP LTT) x y
645 IntLeOp -> trivialCode (CMP LE) x y
647 WordGtOp -> trivialCode (CMP ULT) y x
648 WordGeOp -> trivialCode (CMP ULE) x y
649 WordEqOp -> trivialCode (CMP EQQ) x y
650 WordNeOp -> int_NE_code x y
651 WordLtOp -> trivialCode (CMP ULT) x y
652 WordLeOp -> trivialCode (CMP ULE) x y
654 AddrGtOp -> trivialCode (CMP ULT) y x
655 AddrGeOp -> trivialCode (CMP ULE) y x
656 AddrEqOp -> trivialCode (CMP EQQ) x y
657 AddrNeOp -> int_NE_code x y
658 AddrLtOp -> trivialCode (CMP ULT) x y
659 AddrLeOp -> trivialCode (CMP ULE) x y
661 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
662 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
663 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
664 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
665 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
666 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
668 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
669 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
670 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
671 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
672 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
673 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
675 IntAddOp -> trivialCode (ADD Q False) x y
676 IntSubOp -> trivialCode (SUB Q False) x y
677 IntMulOp -> trivialCode (MUL Q False) x y
678 IntQuotOp -> trivialCode (DIV Q False) x y
679 IntRemOp -> trivialCode (REM Q False) x y
681 WordAddOp -> trivialCode (ADD Q False) x y
682 WordSubOp -> trivialCode (SUB Q False) x y
683 WordMulOp -> trivialCode (MUL Q False) x y
684 WordQuotOp -> trivialCode (DIV Q True) x y
685 WordRemOp -> trivialCode (REM Q True) x y
687 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
688 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
689 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
690 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
692 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
693 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
694 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
695 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
697 AddrAddOp -> trivialCode (ADD Q False) x y
698 AddrSubOp -> trivialCode (SUB Q False) x y
699 AddrRemOp -> trivialCode (REM Q True) x y
701 AndOp -> trivialCode AND x y
702 OrOp -> trivialCode OR x y
703 XorOp -> trivialCode XOR x y
704 SllOp -> trivialCode SLL x y
705 SrlOp -> trivialCode SRL x y
707 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
708 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
709 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
711 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
712 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
714 {- ------------------------------------------------------------
715 Some bizarre special code for getting condition codes into
716 registers. Integer non-equality is a test for equality
717 followed by an XOR with 1. (Integer comparisons always set
718 the result register to 0 or 1.) Floating point comparisons of
719 any kind leave the result in a floating point register, so we
720 need to wrangle an integer register out of things.
722 int_NE_code :: StixTree -> StixTree -> NatM Register
725 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
726 getNewRegNCG IntRep `thenNat` \ tmp ->
728 code = registerCode register tmp
729 src = registerName register tmp
730 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
732 returnNat (Any IntRep code__2)
734 {- ------------------------------------------------------------
735 Comments for int_NE_code also apply to cmpF_code
738 :: (Reg -> Reg -> Reg -> Instr)
740 -> StixTree -> StixTree
743 cmpF_code instr cond x y
744 = trivialFCode pr instr x y `thenNat` \ register ->
745 getNewRegNCG DoubleRep `thenNat` \ tmp ->
746 getNatLabelNCG `thenNat` \ lbl ->
748 code = registerCode register tmp
749 result = registerName register tmp
751 code__2 dst = code . mkSeqInstrs [
752 OR zeroh (RIImm (ImmInt 1)) dst,
753 BF cond result (ImmCLbl lbl),
754 OR zeroh (RIReg zeroh) dst,
757 returnNat (Any IntRep code__2)
759 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
760 ------------------------------------------------------------
762 getRegister (StInd pk mem)
763 = getAmode mem `thenNat` \ amode ->
765 code = amodeCode amode
766 src = amodeAddr amode
767 size = primRepToSize pk
768 code__2 dst = code . mkSeqInstr (LD size dst src)
770 returnNat (Any pk code__2)
772 getRegister (StInt i)
775 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
777 returnNat (Any IntRep code)
780 code dst = mkSeqInstr (LDI Q dst src)
782 returnNat (Any IntRep code)
784 src = ImmInt (fromInteger i)
789 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
791 returnNat (Any PtrRep code)
794 imm__2 = case imm of Just x -> x
796 #endif {- alpha_TARGET_ARCH -}
798 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
802 getRegister (StFloat f)
803 = getNatLabelNCG `thenNat` \ lbl ->
804 let code dst = toOL [
809 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
812 returnNat (Any FloatRep code)
815 getRegister (StDouble d)
818 = let code dst = unitOL (GLDZ dst)
819 in returnNat (Any DoubleRep code)
822 = let code dst = unitOL (GLD1 dst)
823 in returnNat (Any DoubleRep code)
826 = getNatLabelNCG `thenNat` \ lbl ->
827 let code dst = toOL [
830 DATA DF [ImmDouble d],
832 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
835 returnNat (Any DoubleRep code)
838 getRegister (StMachOp mop [x]) -- unary MachOps
840 MO_NatS_Neg -> trivialUCode (NEGI L) x
841 MO_Nat_Not -> trivialUCode (NOT L) x
842 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
844 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
845 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
847 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
848 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
850 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
851 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
853 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
854 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
856 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
857 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
859 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
860 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
861 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
862 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
864 -- Conversions which are a nop on x86
865 MO_32U_to_NatS -> conversionNop IntRep x
866 MO_32S_to_NatS -> conversionNop IntRep x
867 MO_NatS_to_32U -> conversionNop WordRep x
868 MO_32U_to_NatU -> conversionNop WordRep x
870 MO_NatU_to_NatS -> conversionNop IntRep x
871 MO_NatS_to_NatU -> conversionNop WordRep x
872 MO_NatP_to_NatU -> conversionNop WordRep x
873 MO_NatU_to_NatP -> conversionNop PtrRep x
874 MO_NatS_to_NatP -> conversionNop PtrRep x
875 MO_NatP_to_NatS -> conversionNop IntRep x
877 MO_Dbl_to_Flt -> conversionNop FloatRep x
878 MO_Flt_to_Dbl -> conversionNop DoubleRep x
880 -- sign-extending widenings
881 MO_8U_to_NatU -> integerExtend False 24 x
882 MO_8S_to_NatS -> integerExtend True 24 x
883 MO_16U_to_NatU -> integerExtend False 16 x
884 MO_16S_to_NatS -> integerExtend True 16 x
885 MO_8U_to_32U -> integerExtend False 24 x
889 (if is_float_op then demote else id)
890 (StCall (Left fn) CCallConv DoubleRep
891 [(if is_float_op then promote else id) x])
894 integerExtend signed nBits x
896 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
897 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
900 conversionNop new_rep expr
901 = getRegister expr `thenNat` \ e_code ->
902 returnNat (swizzleRegisterRep e_code new_rep)
904 promote x = StMachOp MO_Flt_to_Dbl [x]
905 demote x = StMachOp MO_Dbl_to_Flt [x]
908 MO_Flt_Exp -> (True, FSLIT("exp"))
909 MO_Flt_Log -> (True, FSLIT("log"))
911 MO_Flt_Asin -> (True, FSLIT("asin"))
912 MO_Flt_Acos -> (True, FSLIT("acos"))
913 MO_Flt_Atan -> (True, FSLIT("atan"))
915 MO_Flt_Sinh -> (True, FSLIT("sinh"))
916 MO_Flt_Cosh -> (True, FSLIT("cosh"))
917 MO_Flt_Tanh -> (True, FSLIT("tanh"))
919 MO_Dbl_Exp -> (False, FSLIT("exp"))
920 MO_Dbl_Log -> (False, FSLIT("log"))
922 MO_Dbl_Asin -> (False, FSLIT("asin"))
923 MO_Dbl_Acos -> (False, FSLIT("acos"))
924 MO_Dbl_Atan -> (False, FSLIT("atan"))
926 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
927 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
928 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
930 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
934 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
936 MO_32U_Gt -> condIntReg GTT x y
937 MO_32U_Ge -> condIntReg GE x y
938 MO_32U_Eq -> condIntReg EQQ x y
939 MO_32U_Ne -> condIntReg NE x y
940 MO_32U_Lt -> condIntReg LTT x y
941 MO_32U_Le -> condIntReg LE x y
943 MO_Nat_Eq -> condIntReg EQQ x y
944 MO_Nat_Ne -> condIntReg NE x y
946 MO_NatS_Gt -> condIntReg GTT x y
947 MO_NatS_Ge -> condIntReg GE x y
948 MO_NatS_Lt -> condIntReg LTT x y
949 MO_NatS_Le -> condIntReg LE x y
951 MO_NatU_Gt -> condIntReg GU x y
952 MO_NatU_Ge -> condIntReg GEU x y
953 MO_NatU_Lt -> condIntReg LU x y
954 MO_NatU_Le -> condIntReg LEU x y
956 MO_Flt_Gt -> condFltReg GTT x y
957 MO_Flt_Ge -> condFltReg GE x y
958 MO_Flt_Eq -> condFltReg EQQ x y
959 MO_Flt_Ne -> condFltReg NE x y
960 MO_Flt_Lt -> condFltReg LTT x y
961 MO_Flt_Le -> condFltReg LE x y
963 MO_Dbl_Gt -> condFltReg GTT x y
964 MO_Dbl_Ge -> condFltReg GE x y
965 MO_Dbl_Eq -> condFltReg EQQ x y
966 MO_Dbl_Ne -> condFltReg NE x y
967 MO_Dbl_Lt -> condFltReg LTT x y
968 MO_Dbl_Le -> condFltReg LE x y
970 MO_Nat_Add -> add_code L x y
971 MO_Nat_Sub -> sub_code L x y
972 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
973 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
974 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
975 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
976 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
977 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
978 MO_NatS_MulMayOflo -> imulMayOflo x y
980 MO_Flt_Add -> trivialFCode FloatRep GADD x y
981 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
982 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
983 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
985 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
986 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
987 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
988 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
990 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
991 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
992 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
994 {- Shift ops on x86s have constraints on their source, it
995 either has to be Imm, CL or 1
996 => trivialCode's is not restrictive enough (sigh.)
998 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
999 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1000 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1002 MO_Flt_Pwr -> getRegister (demote
1003 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1004 [promote x, promote y])
1006 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1008 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1010 promote x = StMachOp MO_Flt_to_Dbl [x]
1011 demote x = StMachOp MO_Dbl_to_Flt [x]
1013 --------------------
1014 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1016 = getNewRegNCG IntRep `thenNat` \ t1 ->
1017 getNewRegNCG IntRep `thenNat` \ t2 ->
1018 getNewRegNCG IntRep `thenNat` \ res_lo ->
1019 getNewRegNCG IntRep `thenNat` \ res_hi ->
1020 getRegister a1 `thenNat` \ reg1 ->
1021 getRegister a2 `thenNat` \ reg2 ->
1022 let code1 = registerCode reg1 t1
1023 code2 = registerCode reg2 t2
1024 src1 = registerName reg1 t1
1025 src2 = registerName reg2 t2
1026 code dst = code1 `appOL` code2 `appOL`
1028 MOV L (OpReg src1) (OpReg res_hi),
1029 MOV L (OpReg src2) (OpReg res_lo),
1030 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1031 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1032 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1033 MOV L (OpReg res_lo) (OpReg dst)
1034 -- dst==0 if high part == sign extended low part
1037 returnNat (Any IntRep code)
1039 --------------------
1040 shift_code :: (Imm -> Operand -> Instr)
1045 {- Case1: shift length as immediate -}
1046 -- Code is the same as the first eq. for trivialCode -- sigh.
1047 shift_code instr x y{-amount-}
1049 = getRegister x `thenNat` \ regx ->
1052 then registerCodeA regx dst `bind` \ code_x ->
1054 instr imm__2 (OpReg dst)
1055 else registerCodeF regx `bind` \ code_x ->
1056 registerNameF regx `bind` \ r_x ->
1058 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1059 instr imm__2 (OpReg dst)
1061 returnNat (Any IntRep mkcode)
1064 imm__2 = case imm of Just x -> x
1066 {- Case2: shift length is complex (non-immediate) -}
1067 -- Since ECX is always used as a spill temporary, we can't
1068 -- use it here to do non-immediate shifts. No big deal --
1069 -- they are only very rare, and we can use an equivalent
1070 -- test-and-jump sequence which doesn't use ECX.
1071 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1072 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1073 shift_code instr x y{-amount-}
1074 = getRegister x `thenNat` \ register1 ->
1075 getRegister y `thenNat` \ register2 ->
1076 getNatLabelNCG `thenNat` \ lbl_test3 ->
1077 getNatLabelNCG `thenNat` \ lbl_test2 ->
1078 getNatLabelNCG `thenNat` \ lbl_test1 ->
1079 getNatLabelNCG `thenNat` \ lbl_test0 ->
1080 getNatLabelNCG `thenNat` \ lbl_after ->
1081 getNewRegNCG IntRep `thenNat` \ tmp ->
1083 = let src_val = registerName register1 dst
1084 code_val = registerCode register1 dst
1085 src_amt = registerName register2 tmp
1086 code_amt = registerCode register2 tmp
1091 MOV L (OpReg src_amt) r_tmp `appOL`
1093 MOV L (OpReg src_val) r_dst `appOL`
1095 COMMENT (mkFastString "begin shift sequence"),
1096 MOV L (OpReg src_val) r_dst,
1097 MOV L (OpReg src_amt) r_tmp,
1099 BT L (ImmInt 4) r_tmp,
1101 instr (ImmInt 16) r_dst,
1104 BT L (ImmInt 3) r_tmp,
1106 instr (ImmInt 8) r_dst,
1109 BT L (ImmInt 2) r_tmp,
1111 instr (ImmInt 4) r_dst,
1114 BT L (ImmInt 1) r_tmp,
1116 instr (ImmInt 2) r_dst,
1119 BT L (ImmInt 0) r_tmp,
1121 instr (ImmInt 1) r_dst,
1124 COMMENT (mkFastString "end shift sequence")
1127 returnNat (Any IntRep code__2)
1129 --------------------
1130 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1132 add_code sz x (StInt y)
1133 = getRegister x `thenNat` \ register ->
1134 getNewRegNCG IntRep `thenNat` \ tmp ->
1136 code = registerCode register tmp
1137 src1 = registerName register tmp
1138 src2 = ImmInt (fromInteger y)
1141 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1144 returnNat (Any IntRep code__2)
1146 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1148 --------------------
1149 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1151 sub_code sz x (StInt y)
1152 = getRegister x `thenNat` \ register ->
1153 getNewRegNCG IntRep `thenNat` \ tmp ->
1155 code = registerCode register tmp
1156 src1 = registerName register tmp
1157 src2 = ImmInt (-(fromInteger y))
1160 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1163 returnNat (Any IntRep code__2)
1165 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1167 getRegister (StInd pk mem)
1168 | not (is64BitRep pk)
1169 = getAmode mem `thenNat` \ amode ->
1171 code = amodeCode amode
1172 src = amodeAddr amode
1173 size = primRepToSize pk
1174 code__2 dst = code `snocOL`
1175 if pk == DoubleRep || pk == FloatRep
1176 then GLD size src dst
1184 (OpAddr src) (OpReg dst)
1186 returnNat (Any pk code__2)
1188 getRegister (StInt i)
1190 src = ImmInt (fromInteger i)
1193 = unitOL (XOR L (OpReg dst) (OpReg dst))
1195 = unitOL (MOV L (OpImm src) (OpReg dst))
1197 returnNat (Any IntRep code)
1201 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1203 returnNat (Any PtrRep code)
1205 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1208 imm__2 = case imm of Just x -> x
1210 #endif {- i386_TARGET_ARCH -}
1212 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1214 #if sparc_TARGET_ARCH
1216 getRegister (StFloat d)
1217 = getNatLabelNCG `thenNat` \ lbl ->
1218 getNewRegNCG PtrRep `thenNat` \ tmp ->
1219 let code dst = toOL [
1220 SEGMENT DataSegment,
1222 DATA F [ImmFloat d],
1223 SEGMENT TextSegment,
1224 SETHI (HI (ImmCLbl lbl)) tmp,
1225 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1227 returnNat (Any FloatRep code)
1229 getRegister (StDouble d)
1230 = getNatLabelNCG `thenNat` \ lbl ->
1231 getNewRegNCG PtrRep `thenNat` \ tmp ->
1232 let code dst = toOL [
1233 SEGMENT DataSegment,
1235 DATA DF [ImmDouble d],
1236 SEGMENT TextSegment,
1237 SETHI (HI (ImmCLbl lbl)) tmp,
1238 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1240 returnNat (Any DoubleRep code)
1243 getRegister (StMachOp mop [x]) -- unary PrimOps
1245 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1246 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1247 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
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_32S_to_NatS -> conversionNop IntRep x
1263 MO_NatS_to_32U -> conversionNop WordRep x
1264 MO_32U_to_NatU -> conversionNop WordRep x
1266 MO_NatU_to_NatS -> conversionNop IntRep x
1267 MO_NatS_to_NatU -> conversionNop WordRep x
1268 MO_NatP_to_NatU -> conversionNop WordRep x
1269 MO_NatU_to_NatP -> conversionNop PtrRep x
1270 MO_NatS_to_NatP -> conversionNop PtrRep x
1271 MO_NatP_to_NatS -> conversionNop IntRep x
1273 -- sign-extending widenings
1274 MO_8U_to_32U -> integerExtend False 24 x
1275 MO_8U_to_NatU -> integerExtend False 24 x
1276 MO_8S_to_NatS -> integerExtend True 24 x
1277 MO_16U_to_NatU -> integerExtend False 16 x
1278 MO_16S_to_NatS -> integerExtend True 16 x
1281 let fixed_x = if is_float_op -- promote to double
1282 then StMachOp MO_Flt_to_Dbl [x]
1285 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1287 integerExtend signed nBits x
1289 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1290 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1292 conversionNop new_rep expr
1293 = getRegister expr `thenNat` \ e_code ->
1294 returnNat (swizzleRegisterRep e_code new_rep)
1298 MO_Flt_Exp -> (True, FSLIT("exp"))
1299 MO_Flt_Log -> (True, FSLIT("log"))
1300 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1302 MO_Flt_Sin -> (True, FSLIT("sin"))
1303 MO_Flt_Cos -> (True, FSLIT("cos"))
1304 MO_Flt_Tan -> (True, FSLIT("tan"))
1306 MO_Flt_Asin -> (True, FSLIT("asin"))
1307 MO_Flt_Acos -> (True, FSLIT("acos"))
1308 MO_Flt_Atan -> (True, FSLIT("atan"))
1310 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1311 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1312 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1314 MO_Dbl_Exp -> (False, FSLIT("exp"))
1315 MO_Dbl_Log -> (False, FSLIT("log"))
1316 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1318 MO_Dbl_Sin -> (False, FSLIT("sin"))
1319 MO_Dbl_Cos -> (False, FSLIT("cos"))
1320 MO_Dbl_Tan -> (False, FSLIT("tan"))
1322 MO_Dbl_Asin -> (False, FSLIT("asin"))
1323 MO_Dbl_Acos -> (False, FSLIT("acos"))
1324 MO_Dbl_Atan -> (False, FSLIT("atan"))
1326 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1327 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1328 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1330 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1334 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1336 MO_32U_Gt -> condIntReg GTT x y
1337 MO_32U_Ge -> condIntReg GE x y
1338 MO_32U_Eq -> condIntReg EQQ x y
1339 MO_32U_Ne -> condIntReg NE x y
1340 MO_32U_Lt -> condIntReg LTT x y
1341 MO_32U_Le -> condIntReg LE x y
1343 MO_Nat_Eq -> condIntReg EQQ x y
1344 MO_Nat_Ne -> condIntReg NE x y
1346 MO_NatS_Gt -> condIntReg GTT x y
1347 MO_NatS_Ge -> condIntReg GE x y
1348 MO_NatS_Lt -> condIntReg LTT x y
1349 MO_NatS_Le -> condIntReg LE x y
1351 MO_NatU_Gt -> condIntReg GU x y
1352 MO_NatU_Ge -> condIntReg GEU x y
1353 MO_NatU_Lt -> condIntReg LU x y
1354 MO_NatU_Le -> condIntReg LEU x y
1356 MO_Flt_Gt -> condFltReg GTT x y
1357 MO_Flt_Ge -> condFltReg GE x y
1358 MO_Flt_Eq -> condFltReg EQQ x y
1359 MO_Flt_Ne -> condFltReg NE x y
1360 MO_Flt_Lt -> condFltReg LTT x y
1361 MO_Flt_Le -> condFltReg LE x y
1363 MO_Dbl_Gt -> condFltReg GTT x y
1364 MO_Dbl_Ge -> condFltReg GE x y
1365 MO_Dbl_Eq -> condFltReg EQQ x y
1366 MO_Dbl_Ne -> condFltReg NE x y
1367 MO_Dbl_Lt -> condFltReg LTT x y
1368 MO_Dbl_Le -> condFltReg LE x y
1370 MO_Nat_Add -> trivialCode (ADD False False) x y
1371 MO_Nat_Sub -> trivialCode (SUB False False) x y
1373 MO_NatS_Mul -> trivialCode (SMUL False) x y
1374 MO_NatU_Mul -> trivialCode (UMUL False) x y
1375 MO_NatS_MulMayOflo -> imulMayOflo x y
1377 -- ToDo: teach about V8+ SPARC div instructions
1378 MO_NatS_Quot -> idiv FSLIT(".div") x y
1379 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1380 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1381 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1383 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1384 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1385 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1386 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1388 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1389 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1390 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1391 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1393 MO_Nat_And -> trivialCode (AND False) x y
1394 MO_Nat_Or -> trivialCode (OR False) x y
1395 MO_Nat_Xor -> trivialCode (XOR False) x y
1397 MO_Nat_Shl -> trivialCode SLL x y
1398 MO_Nat_Shr -> trivialCode SRL x y
1399 MO_Nat_Sar -> trivialCode SRA x y
1401 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1402 [promote x, promote y])
1403 where promote x = StMachOp MO_Flt_to_Dbl [x]
1404 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1407 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1409 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1411 --------------------
1412 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1414 = getNewRegNCG IntRep `thenNat` \ t1 ->
1415 getNewRegNCG IntRep `thenNat` \ t2 ->
1416 getNewRegNCG IntRep `thenNat` \ res_lo ->
1417 getNewRegNCG IntRep `thenNat` \ res_hi ->
1418 getRegister a1 `thenNat` \ reg1 ->
1419 getRegister a2 `thenNat` \ reg2 ->
1420 let code1 = registerCode reg1 t1
1421 code2 = registerCode reg2 t2
1422 src1 = registerName reg1 t1
1423 src2 = registerName reg2 t2
1424 code dst = code1 `appOL` code2 `appOL`
1426 SMUL False src1 (RIReg src2) res_lo,
1428 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1429 SUB False False res_lo (RIReg res_hi) dst
1432 returnNat (Any IntRep code)
1434 getRegister (StInd pk mem)
1435 = getAmode mem `thenNat` \ amode ->
1437 code = amodeCode amode
1438 src = amodeAddr amode
1439 size = primRepToSize pk
1440 code__2 dst = code `snocOL` LD size src dst
1442 returnNat (Any pk code__2)
1444 getRegister (StInt i)
1447 src = ImmInt (fromInteger i)
1448 code dst = unitOL (OR False g0 (RIImm src) dst)
1450 returnNat (Any IntRep code)
1456 SETHI (HI imm__2) dst,
1457 OR False dst (RIImm (LO imm__2)) dst]
1459 returnNat (Any PtrRep code)
1461 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1464 imm__2 = case imm of Just x -> x
1466 #endif {- sparc_TARGET_ARCH -}
1468 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1472 %************************************************************************
1474 \subsection{The @Amode@ type}
1476 %************************************************************************
1478 @Amode@s: Memory addressing modes passed up the tree.
1480 data Amode = Amode MachRegsAddr InstrBlock
1482 amodeAddr (Amode addr _) = addr
1483 amodeCode (Amode _ code) = code
1486 Now, given a tree (the argument to an StInd) that references memory,
1487 produce a suitable addressing mode.
1489 A Rule of the Game (tm) for Amodes: use of the addr bit must
1490 immediately follow use of the code part, since the code part puts
1491 values in registers which the addr then refers to. So you can't put
1492 anything in between, lest it overwrite some of those registers. If
1493 you need to do some other computation between the code part and use of
1494 the addr bit, first store the effective address from the amode in a
1495 temporary, then do the other computation, and then use the temporary:
1499 ... other computation ...
1503 getAmode :: StixExpr -> NatM Amode
1505 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1507 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1509 #if alpha_TARGET_ARCH
1511 getAmode (StPrim IntSubOp [x, StInt i])
1512 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1513 getRegister x `thenNat` \ register ->
1515 code = registerCode register tmp
1516 reg = registerName register tmp
1517 off = ImmInt (-(fromInteger i))
1519 returnNat (Amode (AddrRegImm reg off) code)
1521 getAmode (StPrim IntAddOp [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)
1533 = returnNat (Amode (AddrImm imm__2) id)
1536 imm__2 = case imm of Just x -> x
1539 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1540 getRegister other `thenNat` \ register ->
1542 code = registerCode register tmp
1543 reg = registerName register tmp
1545 returnNat (Amode (AddrReg reg) code)
1547 #endif {- alpha_TARGET_ARCH -}
1549 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1551 #if i386_TARGET_ARCH
1553 -- This is all just ridiculous, since it carefully undoes
1554 -- what mangleIndexTree has just done.
1555 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1556 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1557 getRegister x `thenNat` \ register ->
1559 code = registerCode register tmp
1560 reg = registerName register tmp
1561 off = ImmInt (-(fromInteger i))
1563 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1565 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1567 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1570 imm__2 = case imm of Just x -> x
1572 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1573 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1574 getRegister x `thenNat` \ register ->
1576 code = registerCode register tmp
1577 reg = registerName register tmp
1578 off = ImmInt (fromInteger i)
1580 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1582 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1583 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1584 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1585 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1586 getRegister x `thenNat` \ register1 ->
1587 getRegister y `thenNat` \ register2 ->
1589 code1 = registerCode register1 tmp1
1590 reg1 = registerName register1 tmp1
1591 code2 = registerCode register2 tmp2
1592 reg2 = registerName register2 tmp2
1593 code__2 = code1 `appOL` code2
1594 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1596 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1601 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1604 imm__2 = case imm of Just x -> x
1607 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1608 getRegister other `thenNat` \ register ->
1610 code = registerCode register tmp
1611 reg = registerName register tmp
1613 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1615 #endif {- i386_TARGET_ARCH -}
1617 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1619 #if sparc_TARGET_ARCH
1621 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1623 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1624 getRegister x `thenNat` \ register ->
1626 code = registerCode register tmp
1627 reg = registerName register tmp
1628 off = ImmInt (-(fromInteger i))
1630 returnNat (Amode (AddrRegImm reg off) code)
1633 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1635 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1636 getRegister x `thenNat` \ register ->
1638 code = registerCode register tmp
1639 reg = registerName register tmp
1640 off = ImmInt (fromInteger i)
1642 returnNat (Amode (AddrRegImm reg off) code)
1644 getAmode (StMachOp MO_Nat_Add [x, y])
1645 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1646 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1647 getRegister x `thenNat` \ register1 ->
1648 getRegister y `thenNat` \ register2 ->
1650 code1 = registerCode register1 tmp1
1651 reg1 = registerName register1 tmp1
1652 code2 = registerCode register2 tmp2
1653 reg2 = registerName register2 tmp2
1654 code__2 = code1 `appOL` code2
1656 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1660 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1662 code = unitOL (SETHI (HI imm__2) tmp)
1664 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1667 imm__2 = case imm of Just x -> x
1670 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1671 getRegister other `thenNat` \ register ->
1673 code = registerCode register tmp
1674 reg = registerName register tmp
1677 returnNat (Amode (AddrRegImm reg off) code)
1679 #endif {- sparc_TARGET_ARCH -}
1681 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1684 %************************************************************************
1686 \subsection{The @CondCode@ type}
1688 %************************************************************************
1690 Condition codes passed up the tree.
1692 data CondCode = CondCode Bool Cond InstrBlock
1694 condName (CondCode _ cond _) = cond
1695 condFloat (CondCode is_float _ _) = is_float
1696 condCode (CondCode _ _ code) = code
1699 Set up a condition code for a conditional branch.
1702 getCondCode :: StixExpr -> NatM CondCode
1704 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1706 #if alpha_TARGET_ARCH
1707 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1708 #endif {- alpha_TARGET_ARCH -}
1710 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1712 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1713 -- yes, they really do seem to want exactly the same!
1715 getCondCode (StMachOp mop [x, y])
1717 MO_32U_Gt -> condIntCode GTT x y
1718 MO_32U_Ge -> condIntCode GE x y
1719 MO_32U_Eq -> condIntCode EQQ x y
1720 MO_32U_Ne -> condIntCode NE x y
1721 MO_32U_Lt -> condIntCode LTT x y
1722 MO_32U_Le -> condIntCode LE x y
1724 MO_Nat_Eq -> condIntCode EQQ x y
1725 MO_Nat_Ne -> condIntCode NE x y
1727 MO_NatS_Gt -> condIntCode GTT x y
1728 MO_NatS_Ge -> condIntCode GE x y
1729 MO_NatS_Lt -> condIntCode LTT x y
1730 MO_NatS_Le -> condIntCode LE x y
1732 MO_NatU_Gt -> condIntCode GU x y
1733 MO_NatU_Ge -> condIntCode GEU x y
1734 MO_NatU_Lt -> condIntCode LU x y
1735 MO_NatU_Le -> condIntCode LEU x y
1737 MO_Flt_Gt -> condFltCode GTT x y
1738 MO_Flt_Ge -> condFltCode GE x y
1739 MO_Flt_Eq -> condFltCode EQQ x y
1740 MO_Flt_Ne -> condFltCode NE x y
1741 MO_Flt_Lt -> condFltCode LTT x y
1742 MO_Flt_Le -> condFltCode LE x y
1744 MO_Dbl_Gt -> condFltCode GTT x y
1745 MO_Dbl_Ge -> condFltCode GE x y
1746 MO_Dbl_Eq -> condFltCode EQQ x y
1747 MO_Dbl_Ne -> condFltCode NE x y
1748 MO_Dbl_Lt -> condFltCode LTT x y
1749 MO_Dbl_Le -> condFltCode LE x y
1751 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1753 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1755 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1757 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1762 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1763 passed back up the tree.
1766 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1768 #if alpha_TARGET_ARCH
1769 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1770 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1771 #endif {- alpha_TARGET_ARCH -}
1773 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1774 #if i386_TARGET_ARCH
1776 -- memory vs immediate
1777 condIntCode cond (StInd pk x) y
1778 | Just i <- maybeImm y
1779 = getAmode x `thenNat` \ amode ->
1781 code1 = amodeCode amode
1782 x__2 = amodeAddr amode
1783 sz = primRepToSize pk
1784 code__2 = code1 `snocOL`
1785 CMP sz (OpImm i) (OpAddr x__2)
1787 returnNat (CondCode False cond code__2)
1790 condIntCode cond x (StInt 0)
1791 = getRegister x `thenNat` \ register1 ->
1792 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1794 code1 = registerCode register1 tmp1
1795 src1 = registerName register1 tmp1
1796 code__2 = code1 `snocOL`
1797 TEST L (OpReg src1) (OpReg src1)
1799 returnNat (CondCode False cond code__2)
1801 -- anything vs immediate
1802 condIntCode cond x y
1803 | Just i <- maybeImm y
1804 = getRegister x `thenNat` \ register1 ->
1805 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1807 code1 = registerCode register1 tmp1
1808 src1 = registerName register1 tmp1
1809 code__2 = code1 `snocOL`
1810 CMP L (OpImm i) (OpReg src1)
1812 returnNat (CondCode False cond code__2)
1814 -- memory vs anything
1815 condIntCode cond (StInd pk x) y
1816 = getAmode x `thenNat` \ amode_x ->
1817 getRegister y `thenNat` \ reg_y ->
1818 getNewRegNCG IntRep `thenNat` \ tmp ->
1820 c_x = amodeCode amode_x
1821 am_x = amodeAddr amode_x
1822 c_y = registerCode reg_y tmp
1823 r_y = registerName reg_y tmp
1824 sz = primRepToSize pk
1826 -- optimisation: if there's no code for x, just an amode,
1827 -- use whatever reg y winds up in. Assumes that c_y doesn't
1828 -- clobber any regs in the amode am_x, which I'm not sure is
1829 -- justified. The otherwise clause makes the same assumption.
1830 code__2 | isNilOL c_x
1832 CMP sz (OpReg r_y) (OpAddr am_x)
1836 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1838 CMP sz (OpReg tmp) (OpAddr am_x)
1840 returnNat (CondCode False cond code__2)
1842 -- anything vs memory
1844 condIntCode cond y (StInd pk x)
1845 = getAmode x `thenNat` \ amode_x ->
1846 getRegister y `thenNat` \ reg_y ->
1847 getNewRegNCG IntRep `thenNat` \ tmp ->
1849 c_x = amodeCode amode_x
1850 am_x = amodeAddr amode_x
1851 c_y = registerCode reg_y tmp
1852 r_y = registerName reg_y tmp
1853 sz = primRepToSize pk
1854 -- same optimisation and nagging doubts as previous clause
1855 code__2 | isNilOL c_x
1857 CMP sz (OpAddr am_x) (OpReg r_y)
1861 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1863 CMP sz (OpAddr am_x) (OpReg tmp)
1865 returnNat (CondCode False cond code__2)
1867 -- anything vs anything
1868 condIntCode cond x y
1869 = getRegister x `thenNat` \ register1 ->
1870 getRegister y `thenNat` \ register2 ->
1871 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1872 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1874 code1 = registerCode register1 tmp1
1875 src1 = registerName register1 tmp1
1876 code2 = registerCode register2 tmp2
1877 src2 = registerName register2 tmp2
1878 code__2 = code1 `snocOL`
1879 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1881 CMP L (OpReg src2) (OpReg tmp1)
1883 returnNat (CondCode False cond code__2)
1886 condFltCode cond x y
1887 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1888 getRegister x `thenNat` \ register1 ->
1889 getRegister y `thenNat` \ register2 ->
1890 getNewRegNCG (registerRep register1)
1892 getNewRegNCG (registerRep register2)
1894 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1896 code1 = registerCode register1 tmp1
1897 src1 = registerName register1 tmp1
1899 code2 = registerCode register2 tmp2
1900 src2 = registerName register2 tmp2
1902 code__2 | isAny register1
1903 = code1 `appOL` -- result in tmp1
1909 GMOV src1 tmp1 `appOL`
1913 -- The GCMP insn does the test and sets the zero flag if comparable
1914 -- and true. Hence we always supply EQQ as the condition to test.
1915 returnNat (CondCode True EQQ code__2)
1917 #endif {- i386_TARGET_ARCH -}
1919 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1921 #if sparc_TARGET_ARCH
1923 condIntCode cond x (StInt y)
1925 = getRegister x `thenNat` \ register ->
1926 getNewRegNCG IntRep `thenNat` \ tmp ->
1928 code = registerCode register tmp
1929 src1 = registerName register tmp
1930 src2 = ImmInt (fromInteger y)
1931 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1933 returnNat (CondCode False cond code__2)
1935 condIntCode cond x y
1936 = getRegister x `thenNat` \ register1 ->
1937 getRegister y `thenNat` \ register2 ->
1938 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1939 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1941 code1 = registerCode register1 tmp1
1942 src1 = registerName register1 tmp1
1943 code2 = registerCode register2 tmp2
1944 src2 = registerName register2 tmp2
1945 code__2 = code1 `appOL` code2 `snocOL`
1946 SUB False True src1 (RIReg src2) g0
1948 returnNat (CondCode False cond code__2)
1951 condFltCode cond x y
1952 = getRegister x `thenNat` \ register1 ->
1953 getRegister y `thenNat` \ register2 ->
1954 getNewRegNCG (registerRep register1)
1956 getNewRegNCG (registerRep register2)
1958 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1960 promote x = FxTOy F DF x tmp
1962 pk1 = registerRep register1
1963 code1 = registerCode register1 tmp1
1964 src1 = registerName register1 tmp1
1966 pk2 = registerRep register2
1967 code2 = registerCode register2 tmp2
1968 src2 = registerName register2 tmp2
1972 code1 `appOL` code2 `snocOL`
1973 FCMP True (primRepToSize pk1) src1 src2
1974 else if pk1 == FloatRep then
1975 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1976 FCMP True DF tmp src2
1978 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1979 FCMP True DF src1 tmp
1981 returnNat (CondCode True cond code__2)
1983 #endif {- sparc_TARGET_ARCH -}
1985 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1988 %************************************************************************
1990 \subsection{Generating assignments}
1992 %************************************************************************
1994 Assignments are really at the heart of the whole code generation
1995 business. Almost all top-level nodes of any real importance are
1996 assignments, which correspond to loads, stores, or register transfers.
1997 If we're really lucky, some of the register transfers will go away,
1998 because we can use the destination register to complete the code
1999 generation for the right hand side. This only fails when the right
2000 hand side is forced into a fixed register (e.g. the result of a call).
2003 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2004 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2006 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2007 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2009 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2011 #if alpha_TARGET_ARCH
2013 assignIntCode pk (StInd _ dst) src
2014 = getNewRegNCG IntRep `thenNat` \ tmp ->
2015 getAmode dst `thenNat` \ amode ->
2016 getRegister src `thenNat` \ register ->
2018 code1 = amodeCode amode []
2019 dst__2 = amodeAddr amode
2020 code2 = registerCode register tmp []
2021 src__2 = registerName register tmp
2022 sz = primRepToSize pk
2023 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2027 assignIntCode pk dst src
2028 = getRegister dst `thenNat` \ register1 ->
2029 getRegister src `thenNat` \ register2 ->
2031 dst__2 = registerName register1 zeroh
2032 code = registerCode register2 dst__2
2033 src__2 = registerName register2 dst__2
2034 code__2 = if isFixed register2
2035 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2040 #endif {- alpha_TARGET_ARCH -}
2042 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2044 #if i386_TARGET_ARCH
2046 -- non-FP assignment to memory
2047 assignMem_IntCode pk addr src
2048 = getAmode addr `thenNat` \ amode ->
2049 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2050 getNewRegNCG PtrRep `thenNat` \ tmp ->
2052 -- In general, if the address computation for dst may require
2053 -- some insns preceding the addressing mode itself. So there's
2054 -- no guarantee that the code for dst and the code for src won't
2055 -- write the same register. This means either the address or
2056 -- the value needs to be copied into a temporary. We detect the
2057 -- common case where the amode has no code, and elide the copy.
2058 codea = amodeCode amode
2059 dst__a = amodeAddr amode
2061 code | isNilOL codea
2063 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2066 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2068 MOV (primRepToSize pk) opsrc
2069 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2075 -> NatM (InstrBlock,Operand) -- code, operator
2078 | Just x <- maybeImm op
2079 = returnNat (nilOL, OpImm x)
2082 = getRegister op `thenNat` \ register ->
2083 getNewRegNCG (registerRep register)
2085 let code = registerCode register tmp
2086 reg = registerName register tmp
2088 returnNat (code, OpReg reg)
2090 -- Assign; dst is a reg, rhs is mem
2091 assignReg_IntCode pk reg (StInd pks src)
2092 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2093 getAmode src `thenNat` \ amode ->
2094 getRegisterReg reg `thenNat` \ reg_dst ->
2096 c_addr = amodeCode amode
2097 am_addr = amodeAddr amode
2098 r_dst = registerName reg_dst tmp
2099 szs = primRepToSize pks
2108 code = c_addr `snocOL`
2109 opc (OpAddr am_addr) (OpReg r_dst)
2113 -- dst is a reg, but src could be anything
2114 assignReg_IntCode pk reg src
2115 = getRegisterReg reg `thenNat` \ registerd ->
2116 getRegister src `thenNat` \ registers ->
2117 getNewRegNCG IntRep `thenNat` \ tmp ->
2119 r_dst = registerName registerd tmp
2120 r_src = registerName registers r_dst
2121 c_src = registerCode registers r_dst
2123 code = c_src `snocOL`
2124 MOV L (OpReg r_src) (OpReg r_dst)
2128 #endif {- i386_TARGET_ARCH -}
2130 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2132 #if sparc_TARGET_ARCH
2134 assignMem_IntCode pk addr src
2135 = getNewRegNCG IntRep `thenNat` \ tmp ->
2136 getAmode addr `thenNat` \ amode ->
2137 getRegister src `thenNat` \ register ->
2139 code1 = amodeCode amode
2140 dst__2 = amodeAddr amode
2141 code2 = registerCode register tmp
2142 src__2 = registerName register tmp
2143 sz = primRepToSize pk
2144 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2148 assignReg_IntCode pk reg src
2149 = getRegister src `thenNat` \ register2 ->
2150 getRegisterReg reg `thenNat` \ register1 ->
2152 dst__2 = registerName register1 g0
2153 code = registerCode register2 dst__2
2154 src__2 = registerName register2 dst__2
2155 code__2 = if isFixed register2
2156 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2161 #endif {- sparc_TARGET_ARCH -}
2163 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2166 % --------------------------------
2167 Floating-point assignments:
2168 % --------------------------------
2171 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2172 #if alpha_TARGET_ARCH
2174 assignFltCode pk (StInd _ dst) src
2175 = getNewRegNCG pk `thenNat` \ tmp ->
2176 getAmode dst `thenNat` \ amode ->
2177 getRegister src `thenNat` \ register ->
2179 code1 = amodeCode amode []
2180 dst__2 = amodeAddr amode
2181 code2 = registerCode register tmp []
2182 src__2 = registerName register tmp
2183 sz = primRepToSize pk
2184 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2188 assignFltCode pk dst src
2189 = getRegister dst `thenNat` \ register1 ->
2190 getRegister src `thenNat` \ register2 ->
2192 dst__2 = registerName register1 zeroh
2193 code = registerCode register2 dst__2
2194 src__2 = registerName register2 dst__2
2195 code__2 = if isFixed register2
2196 then code . mkSeqInstr (FMOV src__2 dst__2)
2201 #endif {- alpha_TARGET_ARCH -}
2203 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2205 #if i386_TARGET_ARCH
2207 -- Floating point assignment to memory
2208 assignMem_FltCode pk addr src
2209 = getRegister src `thenNat` \ reg_src ->
2210 getRegister addr `thenNat` \ reg_addr ->
2211 getNewRegNCG pk `thenNat` \ tmp_src ->
2212 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2213 let r_src = registerName reg_src tmp_src
2214 c_src = registerCode reg_src tmp_src
2215 r_addr = registerName reg_addr tmp_addr
2216 c_addr = registerCode reg_addr tmp_addr
2217 sz = primRepToSize pk
2219 code = c_src `appOL`
2220 -- no need to preserve r_src across the addr computation,
2221 -- since r_src must be a float reg
2222 -- whilst r_addr is an int reg
2225 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2229 -- Floating point assignment to a register/temporary
2230 assignReg_FltCode pk reg src
2231 = getRegisterReg reg `thenNat` \ reg_dst ->
2232 getRegister src `thenNat` \ reg_src ->
2233 getNewRegNCG pk `thenNat` \ tmp ->
2235 r_dst = registerName reg_dst tmp
2236 r_src = registerName reg_src r_dst
2237 c_src = registerCode reg_src r_dst
2239 code = if isFixed reg_src
2240 then c_src `snocOL` GMOV r_src r_dst
2246 #endif {- i386_TARGET_ARCH -}
2248 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2250 #if sparc_TARGET_ARCH
2252 -- Floating point assignment to memory
2253 assignMem_FltCode pk addr src
2254 = getNewRegNCG pk `thenNat` \ tmp1 ->
2255 getAmode addr `thenNat` \ amode ->
2256 getRegister src `thenNat` \ register ->
2258 sz = primRepToSize pk
2259 dst__2 = amodeAddr amode
2261 code1 = amodeCode amode
2262 code2 = registerCode register tmp1
2264 src__2 = registerName register tmp1
2265 pk__2 = registerRep register
2266 sz__2 = primRepToSize pk__2
2268 code__2 = code1 `appOL` code2 `appOL`
2270 then unitOL (ST sz src__2 dst__2)
2271 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2275 -- Floating point assignment to a register/temporary
2276 -- Why is this so bizarrely ugly?
2277 assignReg_FltCode pk reg src
2278 = getRegisterReg reg `thenNat` \ register1 ->
2279 getRegister src `thenNat` \ register2 ->
2281 pk__2 = registerRep register2
2282 sz__2 = primRepToSize pk__2
2284 getNewRegNCG pk__2 `thenNat` \ tmp ->
2286 sz = primRepToSize pk
2287 dst__2 = registerName register1 g0 -- must be Fixed
2288 reg__2 = if pk /= pk__2 then tmp else dst__2
2289 code = registerCode register2 reg__2
2290 src__2 = registerName register2 reg__2
2293 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2294 else if isFixed register2 then
2295 code `snocOL` FMOV sz src__2 dst__2
2301 #endif {- sparc_TARGET_ARCH -}
2303 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2306 %************************************************************************
2308 \subsection{Generating an unconditional branch}
2310 %************************************************************************
2312 We accept two types of targets: an immediate CLabel or a tree that
2313 gets evaluated into a register. Any CLabels which are AsmTemporaries
2314 are assumed to be in the local block of code, close enough for a
2315 branch instruction. Other CLabels are assumed to be far away.
2317 (If applicable) Do not fill the delay slots here; you will confuse the
2321 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2323 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2325 #if alpha_TARGET_ARCH
2327 genJump (StCLbl lbl)
2328 | isAsmTemp lbl = returnInstr (BR target)
2329 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2331 target = ImmCLbl lbl
2334 = getRegister tree `thenNat` \ register ->
2335 getNewRegNCG PtrRep `thenNat` \ tmp ->
2337 dst = registerName register pv
2338 code = registerCode register pv
2339 target = registerName register pv
2341 if isFixed register then
2342 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2344 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2346 #endif {- alpha_TARGET_ARCH -}
2348 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2350 #if i386_TARGET_ARCH
2352 genJump dsts (StInd pk mem)
2353 = getAmode mem `thenNat` \ amode ->
2355 code = amodeCode amode
2356 target = amodeAddr amode
2358 returnNat (code `snocOL` JMP dsts (OpAddr target))
2362 = returnNat (unitOL (JMP dsts (OpImm target)))
2365 = getRegister tree `thenNat` \ register ->
2366 getNewRegNCG PtrRep `thenNat` \ tmp ->
2368 code = registerCode register tmp
2369 target = registerName register tmp
2371 returnNat (code `snocOL` JMP dsts (OpReg target))
2374 target = case imm of Just x -> x
2376 #endif {- i386_TARGET_ARCH -}
2378 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2380 #if sparc_TARGET_ARCH
2382 genJump dsts (StCLbl lbl)
2383 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2384 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2385 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2387 target = ImmCLbl lbl
2390 = getRegister tree `thenNat` \ register ->
2391 getNewRegNCG PtrRep `thenNat` \ tmp ->
2393 code = registerCode register tmp
2394 target = registerName register tmp
2396 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2398 #endif {- sparc_TARGET_ARCH -}
2400 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2403 %************************************************************************
2405 \subsection{Conditional jumps}
2407 %************************************************************************
2409 Conditional jumps are always to local labels, so we can use branch
2410 instructions. We peek at the arguments to decide what kind of
2413 ALPHA: For comparisons with 0, we're laughing, because we can just do
2414 the desired conditional branch.
2416 I386: First, we have to ensure that the condition
2417 codes are set according to the supplied comparison operation.
2419 SPARC: First, we have to ensure that the condition codes are set
2420 according to the supplied comparison operation. We generate slightly
2421 different code for floating point comparisons, because a floating
2422 point operation cannot directly precede a @BF@. We assume the worst
2423 and fill that slot with a @NOP@.
2425 SPARC: Do not fill the delay slots here; you will confuse the register
2430 :: CLabel -- the branch target
2431 -> StixExpr -- the condition on which to branch
2434 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2436 #if alpha_TARGET_ARCH
2438 genCondJump lbl (StPrim op [x, StInt 0])
2439 = getRegister x `thenNat` \ register ->
2440 getNewRegNCG (registerRep register)
2443 code = registerCode register tmp
2444 value = registerName register tmp
2445 pk = registerRep register
2446 target = ImmCLbl lbl
2448 returnSeq code [BI (cmpOp op) value target]
2450 cmpOp CharGtOp = GTT
2452 cmpOp CharEqOp = EQQ
2454 cmpOp CharLtOp = LTT
2463 cmpOp WordGeOp = ALWAYS
2464 cmpOp WordEqOp = EQQ
2466 cmpOp WordLtOp = NEVER
2467 cmpOp WordLeOp = EQQ
2469 cmpOp AddrGeOp = ALWAYS
2470 cmpOp AddrEqOp = EQQ
2472 cmpOp AddrLtOp = NEVER
2473 cmpOp AddrLeOp = EQQ
2475 genCondJump lbl (StPrim op [x, StDouble 0.0])
2476 = getRegister x `thenNat` \ register ->
2477 getNewRegNCG (registerRep register)
2480 code = registerCode register tmp
2481 value = registerName register tmp
2482 pk = registerRep register
2483 target = ImmCLbl lbl
2485 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2487 cmpOp FloatGtOp = GTT
2488 cmpOp FloatGeOp = GE
2489 cmpOp FloatEqOp = EQQ
2490 cmpOp FloatNeOp = NE
2491 cmpOp FloatLtOp = LTT
2492 cmpOp FloatLeOp = LE
2493 cmpOp DoubleGtOp = GTT
2494 cmpOp DoubleGeOp = GE
2495 cmpOp DoubleEqOp = EQQ
2496 cmpOp DoubleNeOp = NE
2497 cmpOp DoubleLtOp = LTT
2498 cmpOp DoubleLeOp = LE
2500 genCondJump lbl (StPrim op [x, y])
2502 = trivialFCode pr instr x y `thenNat` \ register ->
2503 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2505 code = registerCode register tmp
2506 result = registerName register tmp
2507 target = ImmCLbl lbl
2509 returnNat (code . mkSeqInstr (BF cond result target))
2511 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2513 fltCmpOp op = case op of
2527 (instr, cond) = case op of
2528 FloatGtOp -> (FCMP TF LE, EQQ)
2529 FloatGeOp -> (FCMP TF LTT, EQQ)
2530 FloatEqOp -> (FCMP TF EQQ, NE)
2531 FloatNeOp -> (FCMP TF EQQ, EQQ)
2532 FloatLtOp -> (FCMP TF LTT, NE)
2533 FloatLeOp -> (FCMP TF LE, NE)
2534 DoubleGtOp -> (FCMP TF LE, EQQ)
2535 DoubleGeOp -> (FCMP TF LTT, EQQ)
2536 DoubleEqOp -> (FCMP TF EQQ, NE)
2537 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2538 DoubleLtOp -> (FCMP TF LTT, NE)
2539 DoubleLeOp -> (FCMP TF LE, NE)
2541 genCondJump lbl (StPrim op [x, y])
2542 = trivialCode instr x y `thenNat` \ register ->
2543 getNewRegNCG IntRep `thenNat` \ tmp ->
2545 code = registerCode register tmp
2546 result = registerName register tmp
2547 target = ImmCLbl lbl
2549 returnNat (code . mkSeqInstr (BI cond result target))
2551 (instr, cond) = case op of
2552 CharGtOp -> (CMP LE, EQQ)
2553 CharGeOp -> (CMP LTT, EQQ)
2554 CharEqOp -> (CMP EQQ, NE)
2555 CharNeOp -> (CMP EQQ, EQQ)
2556 CharLtOp -> (CMP LTT, NE)
2557 CharLeOp -> (CMP LE, NE)
2558 IntGtOp -> (CMP LE, EQQ)
2559 IntGeOp -> (CMP LTT, EQQ)
2560 IntEqOp -> (CMP EQQ, NE)
2561 IntNeOp -> (CMP EQQ, EQQ)
2562 IntLtOp -> (CMP LTT, NE)
2563 IntLeOp -> (CMP LE, NE)
2564 WordGtOp -> (CMP ULE, EQQ)
2565 WordGeOp -> (CMP ULT, EQQ)
2566 WordEqOp -> (CMP EQQ, NE)
2567 WordNeOp -> (CMP EQQ, EQQ)
2568 WordLtOp -> (CMP ULT, NE)
2569 WordLeOp -> (CMP ULE, NE)
2570 AddrGtOp -> (CMP ULE, EQQ)
2571 AddrGeOp -> (CMP ULT, EQQ)
2572 AddrEqOp -> (CMP EQQ, NE)
2573 AddrNeOp -> (CMP EQQ, EQQ)
2574 AddrLtOp -> (CMP ULT, NE)
2575 AddrLeOp -> (CMP ULE, NE)
2577 #endif {- alpha_TARGET_ARCH -}
2579 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2581 #if i386_TARGET_ARCH
2583 genCondJump lbl bool
2584 = getCondCode bool `thenNat` \ condition ->
2586 code = condCode condition
2587 cond = condName condition
2589 returnNat (code `snocOL` JXX cond lbl)
2591 #endif {- i386_TARGET_ARCH -}
2593 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2595 #if sparc_TARGET_ARCH
2597 genCondJump lbl bool
2598 = getCondCode bool `thenNat` \ condition ->
2600 code = condCode condition
2601 cond = condName condition
2602 target = ImmCLbl lbl
2607 if condFloat condition
2608 then [NOP, BF cond False target, NOP]
2609 else [BI cond False target, NOP]
2613 #endif {- sparc_TARGET_ARCH -}
2615 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2618 %************************************************************************
2620 \subsection{Generating C calls}
2622 %************************************************************************
2624 Now the biggest nightmare---calls. Most of the nastiness is buried in
2625 @get_arg@, which moves the arguments to the correct registers/stack
2626 locations. Apart from that, the code is easy.
2628 (If applicable) Do not fill the delay slots here; you will confuse the
2633 :: (Either FastString StixExpr) -- function to call
2635 -> PrimRep -- type of the result
2636 -> [StixExpr] -- arguments (of mixed type)
2639 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2641 #if alpha_TARGET_ARCH
2643 genCCall fn cconv kind args
2644 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2645 `thenNat` \ ((unused,_), argCode) ->
2647 nRegs = length allArgRegs - length unused
2648 code = asmSeqThen (map ($ []) argCode)
2651 LDA pv (AddrImm (ImmLab (ptext fn))),
2652 JSR ra (AddrReg pv) nRegs,
2653 LDGP gp (AddrReg ra)]
2655 ------------------------
2656 {- Try to get a value into a specific register (or registers) for
2657 a call. The first 6 arguments go into the appropriate
2658 argument register (separate registers for integer and floating
2659 point arguments, but used in lock-step), and the remaining
2660 arguments are dumped to the stack, beginning at 0(sp). Our
2661 first argument is a pair of the list of remaining argument
2662 registers to be assigned for this call and the next stack
2663 offset to use for overflowing arguments. This way,
2664 @get_Arg@ can be applied to all of a call's arguments using
2668 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2669 -> StixTree -- Current argument
2670 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2672 -- We have to use up all of our argument registers first...
2674 get_arg ((iDst,fDst):dsts, offset) arg
2675 = getRegister arg `thenNat` \ register ->
2677 reg = if isFloatingRep pk then fDst else iDst
2678 code = registerCode register reg
2679 src = registerName register reg
2680 pk = registerRep register
2683 if isFloatingRep pk then
2684 ((dsts, offset), if isFixed register then
2685 code . mkSeqInstr (FMOV src fDst)
2688 ((dsts, offset), if isFixed register then
2689 code . mkSeqInstr (OR src (RIReg src) iDst)
2692 -- Once we have run out of argument registers, we move to the
2695 get_arg ([], offset) arg
2696 = getRegister arg `thenNat` \ register ->
2697 getNewRegNCG (registerRep register)
2700 code = registerCode register tmp
2701 src = registerName register tmp
2702 pk = registerRep register
2703 sz = primRepToSize pk
2705 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2707 #endif {- alpha_TARGET_ARCH -}
2709 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2711 #if i386_TARGET_ARCH
2713 genCCall fn cconv ret_rep args
2715 (reverse args) `thenNat` \ sizes_n_codes ->
2716 getDeltaNat `thenNat` \ delta ->
2717 let (sizes, push_codes) = unzip sizes_n_codes
2718 tot_arg_size = sum sizes
2720 -- deal with static vs dynamic call targets
2723 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2725 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2726 ASSERT(case dyn_rep of { L -> True; _ -> False})
2727 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2729 `thenNat` \ callinsns ->
2730 let push_code = concatOL push_codes
2731 call = callinsns `appOL`
2733 -- Deallocate parameters after call for ccall;
2734 -- but not for stdcall (callee does it)
2735 (if cconv == StdCallConv then [] else
2736 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2738 [DELTA (delta + tot_arg_size)]
2741 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2742 returnNat (push_code `appOL` call)
2745 -- function names that begin with '.' are assumed to be special
2746 -- internally generated names like '.mul,' which don't get an
2747 -- underscore prefix
2748 -- ToDo:needed (WDP 96/03) ???
2749 fn_u = unpackFS (unLeft fn)
2752 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2753 | otherwise -- General case
2754 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2756 stdcallsize tot_arg_size
2757 | cconv == StdCallConv = '@':show tot_arg_size
2765 push_arg :: StixExpr{-current argument-}
2766 -> NatM (Int, InstrBlock) -- argsz, code
2769 | is64BitRep arg_rep
2770 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2771 getDeltaNat `thenNat` \ delta ->
2772 setDeltaNat (delta - 8) `thenNat` \ _ ->
2773 let r_lo = VirtualRegI vr_lo
2774 r_hi = getHiVRegFromLo r_lo
2777 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2778 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2781 = get_op arg `thenNat` \ (code, reg, sz) ->
2782 getDeltaNat `thenNat` \ delta ->
2783 arg_size sz `bind` \ size ->
2784 setDeltaNat (delta-size) `thenNat` \ _ ->
2785 if (case sz of DF -> True; F -> True; _ -> False)
2786 then returnNat (size,
2788 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2790 GST sz reg (AddrBaseIndex (Just esp)
2794 else returnNat (size,
2796 PUSH L (OpReg reg) `snocOL`
2800 arg_rep = repOfStixExpr arg
2805 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2808 = getRegister op `thenNat` \ register ->
2809 getNewRegNCG (registerRep register)
2812 code = registerCode register tmp
2813 reg = registerName register tmp
2814 pk = registerRep register
2815 sz = primRepToSize pk
2817 returnNat (code, reg, sz)
2819 #endif {- i386_TARGET_ARCH -}
2821 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2823 #if sparc_TARGET_ARCH
2825 The SPARC calling convention is an absolute
2826 nightmare. The first 6x32 bits of arguments are mapped into
2827 %o0 through %o5, and the remaining arguments are dumped to the
2828 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2830 If we have to put args on the stack, move %o6==%sp down by
2831 the number of words to go on the stack, to ensure there's enough space.
2833 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2834 16 words above the stack pointer is a word for the address of
2835 a structure return value. I use this as a temporary location
2836 for moving values from float to int regs. Certainly it isn't
2837 safe to put anything in the 16 words starting at %sp, since
2838 this area can get trashed at any time due to window overflows
2839 caused by signal handlers.
2841 A final complication (if the above isn't enough) is that
2842 we can't blithely calculate the arguments one by one into
2843 %o0 .. %o5. Consider the following nested calls:
2847 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2848 the inner call will itself use %o0, which trashes the value put there
2849 in preparation for the outer call. Upshot: we need to calculate the
2850 args into temporary regs, and move those to arg regs or onto the
2851 stack only immediately prior to the call proper. Sigh.
2854 genCCall fn cconv kind args
2855 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2857 (argcodes, vregss) = unzip argcode_and_vregs
2858 n_argRegs = length allArgRegs
2859 n_argRegs_used = min (length vregs) n_argRegs
2860 vregs = concat vregss
2862 -- deal with static vs dynamic call targets
2865 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2867 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2868 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2870 `thenNat` \ callinsns ->
2872 argcode = concatOL argcodes
2873 (move_sp_down, move_sp_up)
2874 = let diff = length vregs - n_argRegs
2875 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
2878 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2880 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2882 returnNat (argcode `appOL`
2883 move_sp_down `appOL`
2884 transfer_code `appOL`
2889 -- function names that begin with '.' are assumed to be special
2890 -- internally generated names like '.mul,' which don't get an
2891 -- underscore prefix
2892 -- ToDo:needed (WDP 96/03) ???
2893 fn_static = unLeft fn
2894 fn__2 = case (headFS fn_static) of
2895 '.' -> ImmLit (ftext fn_static)
2896 _ -> ImmLab False (ftext fn_static)
2898 -- move args from the integer vregs into which they have been
2899 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2900 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2902 move_final [] _ offset -- all args done
2905 move_final (v:vs) [] offset -- out of aregs; move to stack
2906 = ST W v (spRel offset)
2907 : move_final vs [] (offset+1)
2909 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2910 = OR False g0 (RIReg v) a
2911 : move_final vs az offset
2913 -- generate code to calculate an argument, and move it into one
2914 -- or two integer vregs.
2915 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2916 arg_to_int_vregs arg
2917 | is64BitRep (repOfStixExpr arg)
2918 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2919 let r_lo = VirtualRegI vr_lo
2920 r_hi = getHiVRegFromLo r_lo
2921 in returnNat (code, [r_hi, r_lo])
2923 = getRegister arg `thenNat` \ register ->
2924 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2925 let code = registerCode register tmp
2926 src = registerName register tmp
2927 pk = registerRep register
2929 -- the value is in src. Get it into 1 or 2 int vregs.
2932 getNewRegNCG WordRep `thenNat` \ v1 ->
2933 getNewRegNCG WordRep `thenNat` \ v2 ->
2936 FMOV DF src f0 `snocOL`
2937 ST F f0 (spRel 16) `snocOL`
2938 LD W (spRel 16) v1 `snocOL`
2939 ST F (fPair f0) (spRel 16) `snocOL`
2945 getNewRegNCG WordRep `thenNat` \ v1 ->
2948 ST F src (spRel 16) `snocOL`
2954 getNewRegNCG WordRep `thenNat` \ v1 ->
2956 code `snocOL` OR False g0 (RIReg src) v1
2960 #endif {- sparc_TARGET_ARCH -}
2962 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2965 %************************************************************************
2967 \subsection{Support bits}
2969 %************************************************************************
2971 %************************************************************************
2973 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2975 %************************************************************************
2977 Turn those condition codes into integers now (when they appear on
2978 the right hand side of an assignment).
2980 (If applicable) Do not fill the delay slots here; you will confuse the
2984 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2986 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2988 #if alpha_TARGET_ARCH
2989 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2990 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2991 #endif {- alpha_TARGET_ARCH -}
2993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2995 #if i386_TARGET_ARCH
2998 = condIntCode cond x y `thenNat` \ condition ->
2999 getNewRegNCG IntRep `thenNat` \ tmp ->
3001 code = condCode condition
3002 cond = condName condition
3003 code__2 dst = code `appOL` toOL [
3004 SETCC cond (OpReg tmp),
3005 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3006 MOV L (OpReg tmp) (OpReg dst)]
3008 returnNat (Any IntRep code__2)
3011 = getNatLabelNCG `thenNat` \ lbl1 ->
3012 getNatLabelNCG `thenNat` \ lbl2 ->
3013 condFltCode cond x y `thenNat` \ condition ->
3015 code = condCode condition
3016 cond = condName condition
3017 code__2 dst = code `appOL` toOL [
3019 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3022 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3025 returnNat (Any IntRep code__2)
3027 #endif {- i386_TARGET_ARCH -}
3029 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3031 #if sparc_TARGET_ARCH
3033 condIntReg EQQ x (StInt 0)
3034 = getRegister x `thenNat` \ register ->
3035 getNewRegNCG IntRep `thenNat` \ tmp ->
3037 code = registerCode register tmp
3038 src = registerName register tmp
3039 code__2 dst = code `appOL` toOL [
3040 SUB False True g0 (RIReg src) g0,
3041 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3043 returnNat (Any IntRep code__2)
3046 = getRegister x `thenNat` \ register1 ->
3047 getRegister y `thenNat` \ register2 ->
3048 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3049 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3051 code1 = registerCode register1 tmp1
3052 src1 = registerName register1 tmp1
3053 code2 = registerCode register2 tmp2
3054 src2 = registerName register2 tmp2
3055 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3056 XOR False src1 (RIReg src2) dst,
3057 SUB False True g0 (RIReg dst) g0,
3058 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3060 returnNat (Any IntRep code__2)
3062 condIntReg NE x (StInt 0)
3063 = getRegister x `thenNat` \ register ->
3064 getNewRegNCG IntRep `thenNat` \ tmp ->
3066 code = registerCode register tmp
3067 src = registerName register tmp
3068 code__2 dst = code `appOL` toOL [
3069 SUB False True g0 (RIReg src) g0,
3070 ADD True False g0 (RIImm (ImmInt 0)) dst]
3072 returnNat (Any IntRep code__2)
3075 = getRegister x `thenNat` \ register1 ->
3076 getRegister y `thenNat` \ register2 ->
3077 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3078 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3080 code1 = registerCode register1 tmp1
3081 src1 = registerName register1 tmp1
3082 code2 = registerCode register2 tmp2
3083 src2 = registerName register2 tmp2
3084 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3085 XOR False src1 (RIReg src2) dst,
3086 SUB False True g0 (RIReg dst) g0,
3087 ADD True False g0 (RIImm (ImmInt 0)) dst]
3089 returnNat (Any IntRep code__2)
3092 = getNatLabelNCG `thenNat` \ lbl1 ->
3093 getNatLabelNCG `thenNat` \ lbl2 ->
3094 condIntCode cond x y `thenNat` \ condition ->
3096 code = condCode condition
3097 cond = condName condition
3098 code__2 dst = code `appOL` toOL [
3099 BI cond False (ImmCLbl lbl1), NOP,
3100 OR False g0 (RIImm (ImmInt 0)) dst,
3101 BI ALWAYS False (ImmCLbl lbl2), NOP,
3103 OR False g0 (RIImm (ImmInt 1)) dst,
3106 returnNat (Any IntRep code__2)
3109 = getNatLabelNCG `thenNat` \ lbl1 ->
3110 getNatLabelNCG `thenNat` \ lbl2 ->
3111 condFltCode cond x y `thenNat` \ condition ->
3113 code = condCode condition
3114 cond = condName condition
3115 code__2 dst = code `appOL` toOL [
3117 BF cond False (ImmCLbl lbl1), NOP,
3118 OR False g0 (RIImm (ImmInt 0)) dst,
3119 BI ALWAYS False (ImmCLbl lbl2), NOP,
3121 OR False g0 (RIImm (ImmInt 1)) dst,
3124 returnNat (Any IntRep code__2)
3126 #endif {- sparc_TARGET_ARCH -}
3128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3131 %************************************************************************
3133 \subsubsection{@trivial*Code@: deal with trivial instructions}
3135 %************************************************************************
3137 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3138 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3139 for constants on the right hand side, because that's where the generic
3140 optimizer will have put them.
3142 Similarly, for unary instructions, we don't have to worry about
3143 matching an StInt as the argument, because genericOpt will already
3144 have handled the constant-folding.
3148 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3149 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3150 -> Maybe (Operand -> Operand -> Instr)
3151 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3153 -> StixExpr -> StixExpr -- the two arguments
3158 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3159 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3160 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3162 -> StixExpr -> StixExpr -- the two arguments
3166 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3167 ,IF_ARCH_i386 ((Operand -> Instr)
3168 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3170 -> StixExpr -- the one argument
3175 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3176 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3177 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3179 -> StixExpr -- the one argument
3182 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3184 #if alpha_TARGET_ARCH
3186 trivialCode instr x (StInt y)
3188 = getRegister x `thenNat` \ register ->
3189 getNewRegNCG IntRep `thenNat` \ tmp ->
3191 code = registerCode register tmp
3192 src1 = registerName register tmp
3193 src2 = ImmInt (fromInteger y)
3194 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3196 returnNat (Any IntRep code__2)
3198 trivialCode instr x y
3199 = getRegister x `thenNat` \ register1 ->
3200 getRegister y `thenNat` \ register2 ->
3201 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3202 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3204 code1 = registerCode register1 tmp1 []
3205 src1 = registerName register1 tmp1
3206 code2 = registerCode register2 tmp2 []
3207 src2 = registerName register2 tmp2
3208 code__2 dst = asmSeqThen [code1, code2] .
3209 mkSeqInstr (instr src1 (RIReg src2) dst)
3211 returnNat (Any IntRep code__2)
3214 trivialUCode instr x
3215 = getRegister x `thenNat` \ register ->
3216 getNewRegNCG IntRep `thenNat` \ tmp ->
3218 code = registerCode register tmp
3219 src = registerName register tmp
3220 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3222 returnNat (Any IntRep code__2)
3225 trivialFCode _ instr x y
3226 = getRegister x `thenNat` \ register1 ->
3227 getRegister y `thenNat` \ register2 ->
3228 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3229 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3231 code1 = registerCode register1 tmp1
3232 src1 = registerName register1 tmp1
3234 code2 = registerCode register2 tmp2
3235 src2 = registerName register2 tmp2
3237 code__2 dst = asmSeqThen [code1 [], code2 []] .
3238 mkSeqInstr (instr src1 src2 dst)
3240 returnNat (Any DoubleRep code__2)
3242 trivialUFCode _ instr x
3243 = getRegister x `thenNat` \ register ->
3244 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3246 code = registerCode register tmp
3247 src = registerName register tmp
3248 code__2 dst = code . mkSeqInstr (instr src dst)
3250 returnNat (Any DoubleRep code__2)
3252 #endif {- alpha_TARGET_ARCH -}
3254 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3256 #if i386_TARGET_ARCH
3258 The Rules of the Game are:
3260 * You cannot assume anything about the destination register dst;
3261 it may be anything, including a fixed reg.
3263 * You may compute an operand into a fixed reg, but you may not
3264 subsequently change the contents of that fixed reg. If you
3265 want to do so, first copy the value either to a temporary
3266 or into dst. You are free to modify dst even if it happens
3267 to be a fixed reg -- that's not your problem.
3269 * You cannot assume that a fixed reg will stay live over an
3270 arbitrary computation. The same applies to the dst reg.
3272 * Temporary regs obtained from getNewRegNCG are distinct from
3273 each other and from all other regs, and stay live over
3274 arbitrary computations.
3278 trivialCode instr maybe_revinstr a b
3281 = getRegister a `thenNat` \ rega ->
3284 then registerCode rega dst `bind` \ code_a ->
3286 instr (OpImm imm_b) (OpReg dst)
3287 else registerCodeF rega `bind` \ code_a ->
3288 registerNameF rega `bind` \ r_a ->
3290 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3291 instr (OpImm imm_b) (OpReg dst)
3293 returnNat (Any IntRep mkcode)
3296 = getRegister b `thenNat` \ regb ->
3297 getNewRegNCG IntRep `thenNat` \ tmp ->
3298 let revinstr_avail = maybeToBool maybe_revinstr
3299 revinstr = case maybe_revinstr of Just ri -> ri
3303 then registerCode regb dst `bind` \ code_b ->
3305 revinstr (OpImm imm_a) (OpReg dst)
3306 else registerCodeF regb `bind` \ code_b ->
3307 registerNameF regb `bind` \ r_b ->
3309 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3310 revinstr (OpImm imm_a) (OpReg dst)
3314 then registerCode regb tmp `bind` \ code_b ->
3316 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3317 instr (OpReg tmp) (OpReg dst)
3318 else registerCodeF regb `bind` \ code_b ->
3319 registerNameF regb `bind` \ r_b ->
3321 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3322 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3323 instr (OpReg tmp) (OpReg dst)
3325 returnNat (Any IntRep mkcode)
3328 = getRegister a `thenNat` \ rega ->
3329 getRegister b `thenNat` \ regb ->
3330 getNewRegNCG IntRep `thenNat` \ tmp ->
3332 = case (isAny rega, isAny regb) of
3334 -> registerCode regb tmp `bind` \ code_b ->
3335 registerCode rega dst `bind` \ code_a ->
3338 instr (OpReg tmp) (OpReg dst)
3340 -> registerCode rega tmp `bind` \ code_a ->
3341 registerCodeF regb `bind` \ code_b ->
3342 registerNameF regb `bind` \ r_b ->
3345 instr (OpReg r_b) (OpReg tmp) `snocOL`
3346 MOV L (OpReg tmp) (OpReg dst)
3348 -> registerCode regb tmp `bind` \ code_b ->
3349 registerCodeF rega `bind` \ code_a ->
3350 registerNameF rega `bind` \ r_a ->
3353 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3354 instr (OpReg tmp) (OpReg dst)
3356 -> registerCodeF rega `bind` \ code_a ->
3357 registerNameF rega `bind` \ r_a ->
3358 registerCodeF regb `bind` \ code_b ->
3359 registerNameF regb `bind` \ r_b ->
3361 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3363 instr (OpReg r_b) (OpReg tmp) `snocOL`
3364 MOV L (OpReg tmp) (OpReg dst)
3366 returnNat (Any IntRep mkcode)
3369 maybe_imm_a = maybeImm a
3370 is_imm_a = maybeToBool maybe_imm_a
3371 imm_a = case maybe_imm_a of Just imm -> imm
3373 maybe_imm_b = maybeImm b
3374 is_imm_b = maybeToBool maybe_imm_b
3375 imm_b = case maybe_imm_b of Just imm -> imm
3379 trivialUCode instr x
3380 = getRegister x `thenNat` \ register ->
3382 code__2 dst = let code = registerCode register dst
3383 src = registerName register dst
3385 if isFixed register && dst /= src
3386 then toOL [MOV L (OpReg src) (OpReg dst),
3388 else unitOL (instr (OpReg src))
3390 returnNat (Any IntRep code__2)
3393 trivialFCode pk instr x y
3394 = getRegister x `thenNat` \ register1 ->
3395 getRegister y `thenNat` \ register2 ->
3396 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3397 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3399 code1 = registerCode register1 tmp1
3400 src1 = registerName register1 tmp1
3402 code2 = registerCode register2 tmp2
3403 src2 = registerName register2 tmp2
3406 -- treat the common case specially: both operands in
3408 | isAny register1 && isAny register2
3411 instr (primRepToSize pk) src1 src2 dst
3413 -- be paranoid (and inefficient)
3415 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3417 instr (primRepToSize pk) tmp1 src2 dst
3419 returnNat (Any pk code__2)
3423 trivialUFCode pk instr x
3424 = getRegister x `thenNat` \ register ->
3425 getNewRegNCG pk `thenNat` \ tmp ->
3427 code = registerCode register tmp
3428 src = registerName register tmp
3429 code__2 dst = code `snocOL` instr src dst
3431 returnNat (Any pk code__2)
3433 #endif {- i386_TARGET_ARCH -}
3435 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3437 #if sparc_TARGET_ARCH
3439 trivialCode instr x (StInt y)
3441 = getRegister x `thenNat` \ register ->
3442 getNewRegNCG IntRep `thenNat` \ tmp ->
3444 code = registerCode register tmp
3445 src1 = registerName register tmp
3446 src2 = ImmInt (fromInteger y)
3447 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3449 returnNat (Any IntRep code__2)
3451 trivialCode instr x y
3452 = getRegister x `thenNat` \ register1 ->
3453 getRegister y `thenNat` \ register2 ->
3454 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3455 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3457 code1 = registerCode register1 tmp1
3458 src1 = registerName register1 tmp1
3459 code2 = registerCode register2 tmp2
3460 src2 = registerName register2 tmp2
3461 code__2 dst = code1 `appOL` code2 `snocOL`
3462 instr src1 (RIReg src2) dst
3464 returnNat (Any IntRep code__2)
3467 trivialFCode pk instr x y
3468 = getRegister x `thenNat` \ register1 ->
3469 getRegister y `thenNat` \ register2 ->
3470 getNewRegNCG (registerRep register1)
3472 getNewRegNCG (registerRep register2)
3474 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3476 promote x = FxTOy F DF x tmp
3478 pk1 = registerRep register1
3479 code1 = registerCode register1 tmp1
3480 src1 = registerName register1 tmp1
3482 pk2 = registerRep register2
3483 code2 = registerCode register2 tmp2
3484 src2 = registerName register2 tmp2
3488 code1 `appOL` code2 `snocOL`
3489 instr (primRepToSize pk) src1 src2 dst
3490 else if pk1 == FloatRep then
3491 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3492 instr DF tmp src2 dst
3494 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3495 instr DF src1 tmp dst
3497 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3500 trivialUCode instr x
3501 = getRegister x `thenNat` \ register ->
3502 getNewRegNCG IntRep `thenNat` \ tmp ->
3504 code = registerCode register tmp
3505 src = registerName register tmp
3506 code__2 dst = code `snocOL` instr (RIReg src) dst
3508 returnNat (Any IntRep code__2)
3511 trivialUFCode pk instr x
3512 = getRegister x `thenNat` \ register ->
3513 getNewRegNCG pk `thenNat` \ tmp ->
3515 code = registerCode register tmp
3516 src = registerName register tmp
3517 code__2 dst = code `snocOL` instr src dst
3519 returnNat (Any pk code__2)
3521 #endif {- sparc_TARGET_ARCH -}
3523 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3526 %************************************************************************
3528 \subsubsection{Coercing to/from integer/floating-point...}
3530 %************************************************************************
3532 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3533 conversions. We have to store temporaries in memory to move
3534 between the integer and the floating point register sets.
3536 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3537 pretend, on sparc at least, that double and float regs are seperate
3538 kinds, so the value has to be computed into one kind before being
3539 explicitly "converted" to live in the other kind.
3542 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3543 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3545 coerceDbl2Flt :: StixExpr -> NatM Register
3546 coerceFlt2Dbl :: StixExpr -> NatM Register
3550 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3552 #if alpha_TARGET_ARCH
3555 = getRegister x `thenNat` \ register ->
3556 getNewRegNCG IntRep `thenNat` \ reg ->
3558 code = registerCode register reg
3559 src = registerName register reg
3561 code__2 dst = code . mkSeqInstrs [
3563 LD TF dst (spRel 0),
3566 returnNat (Any DoubleRep code__2)
3570 = getRegister x `thenNat` \ register ->
3571 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3573 code = registerCode register tmp
3574 src = registerName register tmp
3576 code__2 dst = code . mkSeqInstrs [
3578 ST TF tmp (spRel 0),
3581 returnNat (Any IntRep code__2)
3583 #endif {- alpha_TARGET_ARCH -}
3585 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3587 #if i386_TARGET_ARCH
3590 = getRegister x `thenNat` \ register ->
3591 getNewRegNCG IntRep `thenNat` \ reg ->
3593 code = registerCode register reg
3594 src = registerName register reg
3595 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3596 code__2 dst = code `snocOL` opc src dst
3598 returnNat (Any pk code__2)
3601 coerceFP2Int fprep x
3602 = getRegister x `thenNat` \ register ->
3603 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3605 code = registerCode register tmp
3606 src = registerName register tmp
3607 pk = registerRep register
3609 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3610 code__2 dst = code `snocOL` opc src dst
3612 returnNat (Any IntRep code__2)
3615 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3616 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3618 #endif {- i386_TARGET_ARCH -}
3620 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3622 #if sparc_TARGET_ARCH
3625 = getRegister x `thenNat` \ register ->
3626 getNewRegNCG IntRep `thenNat` \ reg ->
3628 code = registerCode register reg
3629 src = registerName register reg
3631 code__2 dst = code `appOL` toOL [
3632 ST W src (spRel (-2)),
3633 LD W (spRel (-2)) dst,
3634 FxTOy W (primRepToSize pk) dst dst]
3636 returnNat (Any pk code__2)
3639 coerceFP2Int fprep x
3640 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3641 getRegister x `thenNat` \ register ->
3642 getNewRegNCG fprep `thenNat` \ reg ->
3643 getNewRegNCG FloatRep `thenNat` \ tmp ->
3645 code = registerCode register reg
3646 src = registerName register reg
3647 code__2 dst = code `appOL` toOL [
3648 FxTOy (primRepToSize fprep) W src tmp,
3649 ST W tmp (spRel (-2)),
3650 LD W (spRel (-2)) dst]
3652 returnNat (Any IntRep code__2)
3656 = getRegister x `thenNat` \ register ->
3657 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3658 let code = registerCode register tmp
3659 src = registerName register tmp
3661 returnNat (Any FloatRep
3662 (\dst -> code `snocOL` FxTOy DF F src dst))
3666 = getRegister x `thenNat` \ register ->
3667 getNewRegNCG FloatRep `thenNat` \ tmp ->
3668 let code = registerCode register tmp
3669 src = registerName register tmp
3671 returnNat (Any DoubleRep
3672 (\dst -> code `snocOL` FxTOy F DF src dst))
3674 #endif {- sparc_TARGET_ARCH -}
3676 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -