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_NatS_to_32U -> conversionNop WordRep x
866 MO_32U_to_NatS -> conversionNop IntRep x
867 MO_32U_to_NatU -> conversionNop WordRep x
869 MO_NatU_to_NatS -> conversionNop IntRep x
870 MO_NatS_to_NatU -> conversionNop WordRep x
871 MO_NatP_to_NatU -> conversionNop WordRep x
872 MO_NatU_to_NatP -> conversionNop PtrRep x
873 MO_NatS_to_NatP -> conversionNop PtrRep x
874 MO_NatP_to_NatS -> conversionNop IntRep x
876 MO_Dbl_to_Flt -> conversionNop FloatRep x
877 MO_Flt_to_Dbl -> conversionNop DoubleRep x
879 -- sign-extending widenings
880 MO_8U_to_NatU -> integerExtend False 24 x
881 MO_8S_to_NatS -> integerExtend True 24 x
882 MO_16U_to_NatU -> integerExtend False 16 x
883 MO_16S_to_NatS -> integerExtend True 16 x
884 MO_8U_to_32U -> integerExtend False 24 x
888 (if is_float_op then demote else id)
889 (StCall (Left fn) CCallConv DoubleRep
890 [(if is_float_op then promote else id) x])
893 integerExtend signed nBits x
895 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
896 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
899 conversionNop new_rep expr
900 = getRegister expr `thenNat` \ e_code ->
901 returnNat (swizzleRegisterRep e_code new_rep)
903 promote x = StMachOp MO_Flt_to_Dbl [x]
904 demote x = StMachOp MO_Dbl_to_Flt [x]
907 MO_Flt_Exp -> (True, FSLIT("exp"))
908 MO_Flt_Log -> (True, FSLIT("log"))
910 MO_Flt_Asin -> (True, FSLIT("asin"))
911 MO_Flt_Acos -> (True, FSLIT("acos"))
912 MO_Flt_Atan -> (True, FSLIT("atan"))
914 MO_Flt_Sinh -> (True, FSLIT("sinh"))
915 MO_Flt_Cosh -> (True, FSLIT("cosh"))
916 MO_Flt_Tanh -> (True, FSLIT("tanh"))
918 MO_Dbl_Exp -> (False, FSLIT("exp"))
919 MO_Dbl_Log -> (False, FSLIT("log"))
921 MO_Dbl_Asin -> (False, FSLIT("asin"))
922 MO_Dbl_Acos -> (False, FSLIT("acos"))
923 MO_Dbl_Atan -> (False, FSLIT("atan"))
925 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
926 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
927 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
929 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
933 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
935 MO_32U_Gt -> condIntReg GTT x y
936 MO_32U_Ge -> condIntReg GE x y
937 MO_32U_Eq -> condIntReg EQQ x y
938 MO_32U_Ne -> condIntReg NE x y
939 MO_32U_Lt -> condIntReg LTT x y
940 MO_32U_Le -> condIntReg LE x y
942 MO_Nat_Eq -> condIntReg EQQ x y
943 MO_Nat_Ne -> condIntReg NE x y
945 MO_NatS_Gt -> condIntReg GTT x y
946 MO_NatS_Ge -> condIntReg GE x y
947 MO_NatS_Lt -> condIntReg LTT x y
948 MO_NatS_Le -> condIntReg LE x y
950 MO_NatU_Gt -> condIntReg GU x y
951 MO_NatU_Ge -> condIntReg GEU x y
952 MO_NatU_Lt -> condIntReg LU x y
953 MO_NatU_Le -> condIntReg LEU x y
955 MO_Flt_Gt -> condFltReg GTT x y
956 MO_Flt_Ge -> condFltReg GE x y
957 MO_Flt_Eq -> condFltReg EQQ x y
958 MO_Flt_Ne -> condFltReg NE x y
959 MO_Flt_Lt -> condFltReg LTT x y
960 MO_Flt_Le -> condFltReg LE x y
962 MO_Dbl_Gt -> condFltReg GTT x y
963 MO_Dbl_Ge -> condFltReg GE x y
964 MO_Dbl_Eq -> condFltReg EQQ x y
965 MO_Dbl_Ne -> condFltReg NE x y
966 MO_Dbl_Lt -> condFltReg LTT x y
967 MO_Dbl_Le -> condFltReg LE x y
969 MO_Nat_Add -> add_code L x y
970 MO_Nat_Sub -> sub_code L x y
971 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
972 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
973 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
974 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
975 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
976 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
977 MO_NatS_MulMayOflo -> imulMayOflo x y
979 MO_Flt_Add -> trivialFCode FloatRep GADD x y
980 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
981 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
982 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
984 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
985 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
986 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
987 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
989 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
990 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
991 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
993 {- Shift ops on x86s have constraints on their source, it
994 either has to be Imm, CL or 1
995 => trivialCode's is not restrictive enough (sigh.)
997 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
998 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
999 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1001 MO_Flt_Pwr -> getRegister (demote
1002 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1003 [promote x, promote y])
1005 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1007 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1009 promote x = StMachOp MO_Flt_to_Dbl [x]
1010 demote x = StMachOp MO_Dbl_to_Flt [x]
1012 --------------------
1013 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1015 = getNewRegNCG IntRep `thenNat` \ t1 ->
1016 getNewRegNCG IntRep `thenNat` \ t2 ->
1017 getNewRegNCG IntRep `thenNat` \ res_lo ->
1018 getNewRegNCG IntRep `thenNat` \ res_hi ->
1019 getRegister a1 `thenNat` \ reg1 ->
1020 getRegister a2 `thenNat` \ reg2 ->
1021 let code1 = registerCode reg1 t1
1022 code2 = registerCode reg2 t2
1023 src1 = registerName reg1 t1
1024 src2 = registerName reg2 t2
1025 code dst = code1 `appOL` code2 `appOL`
1027 MOV L (OpReg src1) (OpReg res_hi),
1028 MOV L (OpReg src2) (OpReg res_lo),
1029 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1030 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1031 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1032 MOV L (OpReg res_lo) (OpReg dst)
1033 -- dst==0 if high part == sign extended low part
1036 returnNat (Any IntRep code)
1038 --------------------
1039 shift_code :: (Imm -> Operand -> Instr)
1044 {- Case1: shift length as immediate -}
1045 -- Code is the same as the first eq. for trivialCode -- sigh.
1046 shift_code instr x y{-amount-}
1048 = getRegister x `thenNat` \ regx ->
1051 then registerCodeA regx dst `bind` \ code_x ->
1053 instr imm__2 (OpReg dst)
1054 else registerCodeF regx `bind` \ code_x ->
1055 registerNameF regx `bind` \ r_x ->
1057 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1058 instr imm__2 (OpReg dst)
1060 returnNat (Any IntRep mkcode)
1063 imm__2 = case imm of Just x -> x
1065 {- Case2: shift length is complex (non-immediate) -}
1066 -- Since ECX is always used as a spill temporary, we can't
1067 -- use it here to do non-immediate shifts. No big deal --
1068 -- they are only very rare, and we can use an equivalent
1069 -- test-and-jump sequence which doesn't use ECX.
1070 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1071 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1072 shift_code instr x y{-amount-}
1073 = getRegister x `thenNat` \ register1 ->
1074 getRegister y `thenNat` \ register2 ->
1075 getNatLabelNCG `thenNat` \ lbl_test3 ->
1076 getNatLabelNCG `thenNat` \ lbl_test2 ->
1077 getNatLabelNCG `thenNat` \ lbl_test1 ->
1078 getNatLabelNCG `thenNat` \ lbl_test0 ->
1079 getNatLabelNCG `thenNat` \ lbl_after ->
1080 getNewRegNCG IntRep `thenNat` \ tmp ->
1082 = let src_val = registerName register1 dst
1083 code_val = registerCode register1 dst
1084 src_amt = registerName register2 tmp
1085 code_amt = registerCode register2 tmp
1090 MOV L (OpReg src_amt) r_tmp `appOL`
1092 MOV L (OpReg src_val) r_dst `appOL`
1094 COMMENT (mkFastString "begin shift sequence"),
1095 MOV L (OpReg src_val) r_dst,
1096 MOV L (OpReg src_amt) r_tmp,
1098 BT L (ImmInt 4) r_tmp,
1100 instr (ImmInt 16) r_dst,
1103 BT L (ImmInt 3) r_tmp,
1105 instr (ImmInt 8) r_dst,
1108 BT L (ImmInt 2) r_tmp,
1110 instr (ImmInt 4) r_dst,
1113 BT L (ImmInt 1) r_tmp,
1115 instr (ImmInt 2) r_dst,
1118 BT L (ImmInt 0) r_tmp,
1120 instr (ImmInt 1) r_dst,
1123 COMMENT (mkFastString "end shift sequence")
1126 returnNat (Any IntRep code__2)
1128 --------------------
1129 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1131 add_code sz x (StInt y)
1132 = getRegister x `thenNat` \ register ->
1133 getNewRegNCG IntRep `thenNat` \ tmp ->
1135 code = registerCode register tmp
1136 src1 = registerName register tmp
1137 src2 = ImmInt (fromInteger y)
1140 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1143 returnNat (Any IntRep code__2)
1145 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1147 --------------------
1148 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1150 sub_code sz x (StInt y)
1151 = getRegister x `thenNat` \ register ->
1152 getNewRegNCG IntRep `thenNat` \ tmp ->
1154 code = registerCode register tmp
1155 src1 = registerName register tmp
1156 src2 = ImmInt (-(fromInteger y))
1159 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1162 returnNat (Any IntRep code__2)
1164 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1166 getRegister (StInd pk mem)
1167 | not (is64BitRep pk)
1168 = getAmode mem `thenNat` \ amode ->
1170 code = amodeCode amode
1171 src = amodeAddr amode
1172 size = primRepToSize pk
1173 code__2 dst = code `snocOL`
1174 if pk == DoubleRep || pk == FloatRep
1175 then GLD size src dst
1183 (OpAddr src) (OpReg dst)
1185 returnNat (Any pk code__2)
1187 getRegister (StInt i)
1189 src = ImmInt (fromInteger i)
1192 = unitOL (XOR L (OpReg dst) (OpReg dst))
1194 = unitOL (MOV L (OpImm src) (OpReg dst))
1196 returnNat (Any IntRep code)
1200 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1202 returnNat (Any PtrRep code)
1204 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1207 imm__2 = case imm of Just x -> x
1209 #endif {- i386_TARGET_ARCH -}
1211 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1213 #if sparc_TARGET_ARCH
1215 getRegister (StFloat d)
1216 = getNatLabelNCG `thenNat` \ lbl ->
1217 getNewRegNCG PtrRep `thenNat` \ tmp ->
1218 let code dst = toOL [
1219 SEGMENT DataSegment,
1221 DATA F [ImmFloat d],
1222 SEGMENT TextSegment,
1223 SETHI (HI (ImmCLbl lbl)) tmp,
1224 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1226 returnNat (Any FloatRep code)
1228 getRegister (StDouble d)
1229 = getNatLabelNCG `thenNat` \ lbl ->
1230 getNewRegNCG PtrRep `thenNat` \ tmp ->
1231 let code dst = toOL [
1232 SEGMENT DataSegment,
1234 DATA DF [ImmDouble d],
1235 SEGMENT TextSegment,
1236 SETHI (HI (ImmCLbl lbl)) tmp,
1237 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1239 returnNat (Any DoubleRep code)
1242 getRegister (StMachOp mop [x]) -- unary PrimOps
1244 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1245 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1246 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1248 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1249 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1251 MO_Dbl_to_Flt -> coerceDbl2Flt x
1252 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1254 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1255 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1256 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1257 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1259 -- Conversions which are a nop on sparc
1260 MO_32U_to_NatS -> conversionNop IntRep x
1261 MO_NatS_to_32U -> conversionNop WordRep x
1262 MO_32U_to_NatU -> conversionNop WordRep x
1264 MO_NatU_to_NatS -> conversionNop IntRep x
1265 MO_NatS_to_NatU -> conversionNop WordRep x
1266 MO_NatP_to_NatU -> conversionNop WordRep x
1267 MO_NatU_to_NatP -> conversionNop PtrRep x
1268 MO_NatS_to_NatP -> conversionNop PtrRep x
1269 MO_NatP_to_NatS -> conversionNop IntRep x
1271 -- sign-extending widenings
1272 MO_8U_to_32U -> integerExtend False 24 x
1273 MO_8U_to_NatU -> integerExtend False 24 x
1274 MO_8S_to_NatS -> integerExtend True 24 x
1275 MO_16U_to_NatU -> integerExtend False 16 x
1276 MO_16S_to_NatS -> integerExtend True 16 x
1279 let fixed_x = if is_float_op -- promote to double
1280 then StMachOp MO_Flt_to_Dbl [x]
1283 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1285 integerExtend signed nBits x
1287 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1288 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1290 conversionNop new_rep expr
1291 = getRegister expr `thenNat` \ e_code ->
1292 returnNat (swizzleRegisterRep e_code new_rep)
1296 MO_Flt_Exp -> (True, FSLIT("exp"))
1297 MO_Flt_Log -> (True, FSLIT("log"))
1298 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1300 MO_Flt_Sin -> (True, FSLIT("sin"))
1301 MO_Flt_Cos -> (True, FSLIT("cos"))
1302 MO_Flt_Tan -> (True, FSLIT("tan"))
1304 MO_Flt_Asin -> (True, FSLIT("asin"))
1305 MO_Flt_Acos -> (True, FSLIT("acos"))
1306 MO_Flt_Atan -> (True, FSLIT("atan"))
1308 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1309 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1310 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1312 MO_Dbl_Exp -> (False, FSLIT("exp"))
1313 MO_Dbl_Log -> (False, FSLIT("log"))
1314 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1316 MO_Dbl_Sin -> (False, FSLIT("sin"))
1317 MO_Dbl_Cos -> (False, FSLIT("cos"))
1318 MO_Dbl_Tan -> (False, FSLIT("tan"))
1320 MO_Dbl_Asin -> (False, FSLIT("asin"))
1321 MO_Dbl_Acos -> (False, FSLIT("acos"))
1322 MO_Dbl_Atan -> (False, FSLIT("atan"))
1324 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1325 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1326 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1328 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1332 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1334 MO_32U_Gt -> condIntReg GTT x y
1335 MO_32U_Ge -> condIntReg GE x y
1336 MO_32U_Eq -> condIntReg EQQ x y
1337 MO_32U_Ne -> condIntReg NE x y
1338 MO_32U_Lt -> condIntReg LTT x y
1339 MO_32U_Le -> condIntReg LE x y
1341 MO_Nat_Eq -> condIntReg EQQ x y
1342 MO_Nat_Ne -> condIntReg NE x y
1344 MO_NatS_Gt -> condIntReg GTT x y
1345 MO_NatS_Ge -> condIntReg GE x y
1346 MO_NatS_Lt -> condIntReg LTT x y
1347 MO_NatS_Le -> condIntReg LE x y
1349 MO_NatU_Gt -> condIntReg GU x y
1350 MO_NatU_Ge -> condIntReg GEU x y
1351 MO_NatU_Lt -> condIntReg LU x y
1352 MO_NatU_Le -> condIntReg LEU x y
1354 MO_Flt_Gt -> condFltReg GTT x y
1355 MO_Flt_Ge -> condFltReg GE x y
1356 MO_Flt_Eq -> condFltReg EQQ x y
1357 MO_Flt_Ne -> condFltReg NE x y
1358 MO_Flt_Lt -> condFltReg LTT x y
1359 MO_Flt_Le -> condFltReg LE x y
1361 MO_Dbl_Gt -> condFltReg GTT x y
1362 MO_Dbl_Ge -> condFltReg GE x y
1363 MO_Dbl_Eq -> condFltReg EQQ x y
1364 MO_Dbl_Ne -> condFltReg NE x y
1365 MO_Dbl_Lt -> condFltReg LTT x y
1366 MO_Dbl_Le -> condFltReg LE x y
1368 MO_Nat_Add -> trivialCode (ADD False False) x y
1369 MO_Nat_Sub -> trivialCode (SUB False False) x y
1371 MO_NatS_Mul -> trivialCode (SMUL False) x y
1372 MO_NatU_Mul -> trivialCode (UMUL False) x y
1373 MO_NatS_MulMayOflo -> imulMayOflo x y
1375 -- ToDo: teach about V8+ SPARC div instructions
1376 MO_NatS_Quot -> idiv FSLIT(".div") x y
1377 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1378 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1379 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1381 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1382 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1383 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1384 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1386 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1387 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1388 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1389 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1391 MO_Nat_And -> trivialCode (AND False) x y
1392 MO_Nat_Or -> trivialCode (OR False) x y
1393 MO_Nat_Xor -> trivialCode (XOR False) x y
1395 MO_Nat_Shl -> trivialCode SLL x y
1396 MO_Nat_Shr -> trivialCode SRL x y
1397 MO_Nat_Sar -> trivialCode SRA x y
1399 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1400 [promote x, promote y])
1401 where promote x = StMachOp MO_Flt_to_Dbl [x]
1402 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1405 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1407 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1409 --------------------
1410 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1412 = getNewRegNCG IntRep `thenNat` \ t1 ->
1413 getNewRegNCG IntRep `thenNat` \ t2 ->
1414 getNewRegNCG IntRep `thenNat` \ res_lo ->
1415 getNewRegNCG IntRep `thenNat` \ res_hi ->
1416 getRegister a1 `thenNat` \ reg1 ->
1417 getRegister a2 `thenNat` \ reg2 ->
1418 let code1 = registerCode reg1 t1
1419 code2 = registerCode reg2 t2
1420 src1 = registerName reg1 t1
1421 src2 = registerName reg2 t2
1422 code dst = code1 `appOL` code2 `appOL`
1424 SMUL False src1 (RIReg src2) res_lo,
1426 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1427 SUB False False res_lo (RIReg res_hi) dst
1430 returnNat (Any IntRep code)
1432 getRegister (StInd pk mem)
1433 = getAmode mem `thenNat` \ amode ->
1435 code = amodeCode amode
1436 src = amodeAddr amode
1437 size = primRepToSize pk
1438 code__2 dst = code `snocOL` LD size src dst
1440 returnNat (Any pk code__2)
1442 getRegister (StInt i)
1445 src = ImmInt (fromInteger i)
1446 code dst = unitOL (OR False g0 (RIImm src) dst)
1448 returnNat (Any IntRep code)
1454 SETHI (HI imm__2) dst,
1455 OR False dst (RIImm (LO imm__2)) dst]
1457 returnNat (Any PtrRep code)
1459 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1462 imm__2 = case imm of Just x -> x
1464 #endif {- sparc_TARGET_ARCH -}
1466 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1470 %************************************************************************
1472 \subsection{The @Amode@ type}
1474 %************************************************************************
1476 @Amode@s: Memory addressing modes passed up the tree.
1478 data Amode = Amode MachRegsAddr InstrBlock
1480 amodeAddr (Amode addr _) = addr
1481 amodeCode (Amode _ code) = code
1484 Now, given a tree (the argument to an StInd) that references memory,
1485 produce a suitable addressing mode.
1487 A Rule of the Game (tm) for Amodes: use of the addr bit must
1488 immediately follow use of the code part, since the code part puts
1489 values in registers which the addr then refers to. So you can't put
1490 anything in between, lest it overwrite some of those registers. If
1491 you need to do some other computation between the code part and use of
1492 the addr bit, first store the effective address from the amode in a
1493 temporary, then do the other computation, and then use the temporary:
1497 ... other computation ...
1501 getAmode :: StixExpr -> NatM Amode
1503 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1505 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1507 #if alpha_TARGET_ARCH
1509 getAmode (StPrim IntSubOp [x, StInt i])
1510 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1511 getRegister x `thenNat` \ register ->
1513 code = registerCode register tmp
1514 reg = registerName register tmp
1515 off = ImmInt (-(fromInteger i))
1517 returnNat (Amode (AddrRegImm reg off) code)
1519 getAmode (StPrim IntAddOp [x, StInt i])
1520 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1521 getRegister x `thenNat` \ register ->
1523 code = registerCode register tmp
1524 reg = registerName register tmp
1525 off = ImmInt (fromInteger i)
1527 returnNat (Amode (AddrRegImm reg off) code)
1531 = returnNat (Amode (AddrImm imm__2) id)
1534 imm__2 = case imm of Just x -> x
1537 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1538 getRegister other `thenNat` \ register ->
1540 code = registerCode register tmp
1541 reg = registerName register tmp
1543 returnNat (Amode (AddrReg reg) code)
1545 #endif {- alpha_TARGET_ARCH -}
1547 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1549 #if i386_TARGET_ARCH
1551 -- This is all just ridiculous, since it carefully undoes
1552 -- what mangleIndexTree has just done.
1553 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1554 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1555 getRegister x `thenNat` \ register ->
1557 code = registerCode register tmp
1558 reg = registerName register tmp
1559 off = ImmInt (-(fromInteger i))
1561 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1563 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1565 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1568 imm__2 = case imm of Just x -> x
1570 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1571 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1572 getRegister x `thenNat` \ register ->
1574 code = registerCode register tmp
1575 reg = registerName register tmp
1576 off = ImmInt (fromInteger i)
1578 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1580 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1581 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1582 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1583 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1584 getRegister x `thenNat` \ register1 ->
1585 getRegister y `thenNat` \ register2 ->
1587 code1 = registerCode register1 tmp1
1588 reg1 = registerName register1 tmp1
1589 code2 = registerCode register2 tmp2
1590 reg2 = registerName register2 tmp2
1591 code__2 = code1 `appOL` code2
1592 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1594 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1599 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1602 imm__2 = case imm of Just x -> x
1605 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1606 getRegister other `thenNat` \ register ->
1608 code = registerCode register tmp
1609 reg = registerName register tmp
1611 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1613 #endif {- i386_TARGET_ARCH -}
1615 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1617 #if sparc_TARGET_ARCH
1619 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1621 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1622 getRegister x `thenNat` \ register ->
1624 code = registerCode register tmp
1625 reg = registerName register tmp
1626 off = ImmInt (-(fromInteger i))
1628 returnNat (Amode (AddrRegImm reg off) code)
1631 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1633 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1634 getRegister x `thenNat` \ register ->
1636 code = registerCode register tmp
1637 reg = registerName register tmp
1638 off = ImmInt (fromInteger i)
1640 returnNat (Amode (AddrRegImm reg off) code)
1642 getAmode (StMachOp MO_Nat_Add [x, y])
1643 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1644 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1645 getRegister x `thenNat` \ register1 ->
1646 getRegister y `thenNat` \ register2 ->
1648 code1 = registerCode register1 tmp1
1649 reg1 = registerName register1 tmp1
1650 code2 = registerCode register2 tmp2
1651 reg2 = registerName register2 tmp2
1652 code__2 = code1 `appOL` code2
1654 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1658 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1660 code = unitOL (SETHI (HI imm__2) tmp)
1662 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1665 imm__2 = case imm of Just x -> x
1668 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1669 getRegister other `thenNat` \ register ->
1671 code = registerCode register tmp
1672 reg = registerName register tmp
1675 returnNat (Amode (AddrRegImm reg off) code)
1677 #endif {- sparc_TARGET_ARCH -}
1679 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1682 %************************************************************************
1684 \subsection{The @CondCode@ type}
1686 %************************************************************************
1688 Condition codes passed up the tree.
1690 data CondCode = CondCode Bool Cond InstrBlock
1692 condName (CondCode _ cond _) = cond
1693 condFloat (CondCode is_float _ _) = is_float
1694 condCode (CondCode _ _ code) = code
1697 Set up a condition code for a conditional branch.
1700 getCondCode :: StixExpr -> NatM CondCode
1702 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1704 #if alpha_TARGET_ARCH
1705 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1706 #endif {- alpha_TARGET_ARCH -}
1708 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1710 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1711 -- yes, they really do seem to want exactly the same!
1713 getCondCode (StMachOp mop [x, y])
1715 MO_32U_Gt -> condIntCode GTT x y
1716 MO_32U_Ge -> condIntCode GE x y
1717 MO_32U_Eq -> condIntCode EQQ x y
1718 MO_32U_Ne -> condIntCode NE x y
1719 MO_32U_Lt -> condIntCode LTT x y
1720 MO_32U_Le -> condIntCode LE x y
1722 MO_Nat_Eq -> condIntCode EQQ x y
1723 MO_Nat_Ne -> condIntCode NE x y
1725 MO_NatS_Gt -> condIntCode GTT x y
1726 MO_NatS_Ge -> condIntCode GE x y
1727 MO_NatS_Lt -> condIntCode LTT x y
1728 MO_NatS_Le -> condIntCode LE x y
1730 MO_NatU_Gt -> condIntCode GU x y
1731 MO_NatU_Ge -> condIntCode GEU x y
1732 MO_NatU_Lt -> condIntCode LU x y
1733 MO_NatU_Le -> condIntCode LEU x y
1735 MO_Flt_Gt -> condFltCode GTT x y
1736 MO_Flt_Ge -> condFltCode GE x y
1737 MO_Flt_Eq -> condFltCode EQQ x y
1738 MO_Flt_Ne -> condFltCode NE x y
1739 MO_Flt_Lt -> condFltCode LTT x y
1740 MO_Flt_Le -> condFltCode LE x y
1742 MO_Dbl_Gt -> condFltCode GTT x y
1743 MO_Dbl_Ge -> condFltCode GE x y
1744 MO_Dbl_Eq -> condFltCode EQQ x y
1745 MO_Dbl_Ne -> condFltCode NE x y
1746 MO_Dbl_Lt -> condFltCode LTT x y
1747 MO_Dbl_Le -> condFltCode LE x y
1749 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1751 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1753 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1755 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1760 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1761 passed back up the tree.
1764 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1766 #if alpha_TARGET_ARCH
1767 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1768 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1769 #endif {- alpha_TARGET_ARCH -}
1771 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1772 #if i386_TARGET_ARCH
1774 -- memory vs immediate
1775 condIntCode cond (StInd pk x) y
1776 | Just i <- maybeImm y
1777 = getAmode x `thenNat` \ amode ->
1779 code1 = amodeCode amode
1780 x__2 = amodeAddr amode
1781 sz = primRepToSize pk
1782 code__2 = code1 `snocOL`
1783 CMP sz (OpImm i) (OpAddr x__2)
1785 returnNat (CondCode False cond code__2)
1788 condIntCode cond x (StInt 0)
1789 = getRegister x `thenNat` \ register1 ->
1790 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1792 code1 = registerCode register1 tmp1
1793 src1 = registerName register1 tmp1
1794 code__2 = code1 `snocOL`
1795 TEST L (OpReg src1) (OpReg src1)
1797 returnNat (CondCode False cond code__2)
1799 -- anything vs immediate
1800 condIntCode cond x y
1801 | Just i <- maybeImm y
1802 = getRegister x `thenNat` \ register1 ->
1803 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1805 code1 = registerCode register1 tmp1
1806 src1 = registerName register1 tmp1
1807 code__2 = code1 `snocOL`
1808 CMP L (OpImm i) (OpReg src1)
1810 returnNat (CondCode False cond code__2)
1812 -- memory vs anything
1813 condIntCode cond (StInd pk x) y
1814 = getAmode x `thenNat` \ amode_x ->
1815 getRegister y `thenNat` \ reg_y ->
1816 getNewRegNCG IntRep `thenNat` \ tmp ->
1818 c_x = amodeCode amode_x
1819 am_x = amodeAddr amode_x
1820 c_y = registerCode reg_y tmp
1821 r_y = registerName reg_y tmp
1822 sz = primRepToSize pk
1824 -- optimisation: if there's no code for x, just an amode,
1825 -- use whatever reg y winds up in. Assumes that c_y doesn't
1826 -- clobber any regs in the amode am_x, which I'm not sure is
1827 -- justified. The otherwise clause makes the same assumption.
1828 code__2 | isNilOL c_x
1830 CMP sz (OpReg r_y) (OpAddr am_x)
1834 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1836 CMP sz (OpReg tmp) (OpAddr am_x)
1838 returnNat (CondCode False cond code__2)
1840 -- anything vs memory
1842 condIntCode cond y (StInd pk x)
1843 = getAmode x `thenNat` \ amode_x ->
1844 getRegister y `thenNat` \ reg_y ->
1845 getNewRegNCG IntRep `thenNat` \ tmp ->
1847 c_x = amodeCode amode_x
1848 am_x = amodeAddr amode_x
1849 c_y = registerCode reg_y tmp
1850 r_y = registerName reg_y tmp
1851 sz = primRepToSize pk
1852 -- same optimisation and nagging doubts as previous clause
1853 code__2 | isNilOL c_x
1855 CMP sz (OpAddr am_x) (OpReg r_y)
1859 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1861 CMP sz (OpAddr am_x) (OpReg tmp)
1863 returnNat (CondCode False cond code__2)
1865 -- anything vs anything
1866 condIntCode cond x y
1867 = getRegister x `thenNat` \ register1 ->
1868 getRegister y `thenNat` \ register2 ->
1869 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1870 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1872 code1 = registerCode register1 tmp1
1873 src1 = registerName register1 tmp1
1874 code2 = registerCode register2 tmp2
1875 src2 = registerName register2 tmp2
1876 code__2 = code1 `snocOL`
1877 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1879 CMP L (OpReg src2) (OpReg tmp1)
1881 returnNat (CondCode False cond code__2)
1884 condFltCode cond x y
1885 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1886 getRegister x `thenNat` \ register1 ->
1887 getRegister y `thenNat` \ register2 ->
1888 getNewRegNCG (registerRep register1)
1890 getNewRegNCG (registerRep register2)
1892 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1894 code1 = registerCode register1 tmp1
1895 src1 = registerName register1 tmp1
1897 code2 = registerCode register2 tmp2
1898 src2 = registerName register2 tmp2
1900 code__2 | isAny register1
1901 = code1 `appOL` -- result in tmp1
1907 GMOV src1 tmp1 `appOL`
1911 -- The GCMP insn does the test and sets the zero flag if comparable
1912 -- and true. Hence we always supply EQQ as the condition to test.
1913 returnNat (CondCode True EQQ code__2)
1915 #endif {- i386_TARGET_ARCH -}
1917 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1919 #if sparc_TARGET_ARCH
1921 condIntCode cond x (StInt y)
1923 = getRegister x `thenNat` \ register ->
1924 getNewRegNCG IntRep `thenNat` \ tmp ->
1926 code = registerCode register tmp
1927 src1 = registerName register tmp
1928 src2 = ImmInt (fromInteger y)
1929 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1931 returnNat (CondCode False cond code__2)
1933 condIntCode cond x y
1934 = getRegister x `thenNat` \ register1 ->
1935 getRegister y `thenNat` \ register2 ->
1936 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1937 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1939 code1 = registerCode register1 tmp1
1940 src1 = registerName register1 tmp1
1941 code2 = registerCode register2 tmp2
1942 src2 = registerName register2 tmp2
1943 code__2 = code1 `appOL` code2 `snocOL`
1944 SUB False True src1 (RIReg src2) g0
1946 returnNat (CondCode False cond code__2)
1949 condFltCode cond x y
1950 = getRegister x `thenNat` \ register1 ->
1951 getRegister y `thenNat` \ register2 ->
1952 getNewRegNCG (registerRep register1)
1954 getNewRegNCG (registerRep register2)
1956 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1958 promote x = FxTOy F DF x tmp
1960 pk1 = registerRep register1
1961 code1 = registerCode register1 tmp1
1962 src1 = registerName register1 tmp1
1964 pk2 = registerRep register2
1965 code2 = registerCode register2 tmp2
1966 src2 = registerName register2 tmp2
1970 code1 `appOL` code2 `snocOL`
1971 FCMP True (primRepToSize pk1) src1 src2
1972 else if pk1 == FloatRep then
1973 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1974 FCMP True DF tmp src2
1976 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1977 FCMP True DF src1 tmp
1979 returnNat (CondCode True cond code__2)
1981 #endif {- sparc_TARGET_ARCH -}
1983 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1986 %************************************************************************
1988 \subsection{Generating assignments}
1990 %************************************************************************
1992 Assignments are really at the heart of the whole code generation
1993 business. Almost all top-level nodes of any real importance are
1994 assignments, which correspond to loads, stores, or register transfers.
1995 If we're really lucky, some of the register transfers will go away,
1996 because we can use the destination register to complete the code
1997 generation for the right hand side. This only fails when the right
1998 hand side is forced into a fixed register (e.g. the result of a call).
2001 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2002 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2004 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2005 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2007 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2009 #if alpha_TARGET_ARCH
2011 assignIntCode pk (StInd _ dst) src
2012 = getNewRegNCG IntRep `thenNat` \ tmp ->
2013 getAmode dst `thenNat` \ amode ->
2014 getRegister src `thenNat` \ register ->
2016 code1 = amodeCode amode []
2017 dst__2 = amodeAddr amode
2018 code2 = registerCode register tmp []
2019 src__2 = registerName register tmp
2020 sz = primRepToSize pk
2021 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2025 assignIntCode pk dst src
2026 = getRegister dst `thenNat` \ register1 ->
2027 getRegister src `thenNat` \ register2 ->
2029 dst__2 = registerName register1 zeroh
2030 code = registerCode register2 dst__2
2031 src__2 = registerName register2 dst__2
2032 code__2 = if isFixed register2
2033 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2038 #endif {- alpha_TARGET_ARCH -}
2040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2042 #if i386_TARGET_ARCH
2044 -- non-FP assignment to memory
2045 assignMem_IntCode pk addr src
2046 = getAmode addr `thenNat` \ amode ->
2047 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2048 getNewRegNCG PtrRep `thenNat` \ tmp ->
2050 -- In general, if the address computation for dst may require
2051 -- some insns preceding the addressing mode itself. So there's
2052 -- no guarantee that the code for dst and the code for src won't
2053 -- write the same register. This means either the address or
2054 -- the value needs to be copied into a temporary. We detect the
2055 -- common case where the amode has no code, and elide the copy.
2056 codea = amodeCode amode
2057 dst__a = amodeAddr amode
2059 code | isNilOL codea
2061 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2064 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2066 MOV (primRepToSize pk) opsrc
2067 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2073 -> NatM (InstrBlock,Operand) -- code, operator
2076 | Just x <- maybeImm op
2077 = returnNat (nilOL, OpImm x)
2080 = getRegister op `thenNat` \ register ->
2081 getNewRegNCG (registerRep register)
2083 let code = registerCode register tmp
2084 reg = registerName register tmp
2086 returnNat (code, OpReg reg)
2088 -- Assign; dst is a reg, rhs is mem
2089 assignReg_IntCode pk reg (StInd pks src)
2090 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2091 getAmode src `thenNat` \ amode ->
2092 getRegisterReg reg `thenNat` \ reg_dst ->
2094 c_addr = amodeCode amode
2095 am_addr = amodeAddr amode
2096 r_dst = registerName reg_dst tmp
2097 szs = primRepToSize pks
2106 code = c_addr `snocOL`
2107 opc (OpAddr am_addr) (OpReg r_dst)
2111 -- dst is a reg, but src could be anything
2112 assignReg_IntCode pk reg src
2113 = getRegisterReg reg `thenNat` \ registerd ->
2114 getRegister src `thenNat` \ registers ->
2115 getNewRegNCG IntRep `thenNat` \ tmp ->
2117 r_dst = registerName registerd tmp
2118 r_src = registerName registers r_dst
2119 c_src = registerCode registers r_dst
2121 code = c_src `snocOL`
2122 MOV L (OpReg r_src) (OpReg r_dst)
2126 #endif {- i386_TARGET_ARCH -}
2128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2130 #if sparc_TARGET_ARCH
2132 assignMem_IntCode pk addr src
2133 = getNewRegNCG IntRep `thenNat` \ tmp ->
2134 getAmode addr `thenNat` \ amode ->
2135 getRegister src `thenNat` \ register ->
2137 code1 = amodeCode amode
2138 dst__2 = amodeAddr amode
2139 code2 = registerCode register tmp
2140 src__2 = registerName register tmp
2141 sz = primRepToSize pk
2142 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2146 assignReg_IntCode pk reg src
2147 = getRegister src `thenNat` \ register2 ->
2148 getRegisterReg reg `thenNat` \ register1 ->
2150 dst__2 = registerName register1 g0
2151 code = registerCode register2 dst__2
2152 src__2 = registerName register2 dst__2
2153 code__2 = if isFixed register2
2154 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2159 #endif {- sparc_TARGET_ARCH -}
2161 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2164 % --------------------------------
2165 Floating-point assignments:
2166 % --------------------------------
2169 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2170 #if alpha_TARGET_ARCH
2172 assignFltCode pk (StInd _ dst) src
2173 = getNewRegNCG pk `thenNat` \ tmp ->
2174 getAmode dst `thenNat` \ amode ->
2175 getRegister src `thenNat` \ register ->
2177 code1 = amodeCode amode []
2178 dst__2 = amodeAddr amode
2179 code2 = registerCode register tmp []
2180 src__2 = registerName register tmp
2181 sz = primRepToSize pk
2182 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2186 assignFltCode pk dst src
2187 = getRegister dst `thenNat` \ register1 ->
2188 getRegister src `thenNat` \ register2 ->
2190 dst__2 = registerName register1 zeroh
2191 code = registerCode register2 dst__2
2192 src__2 = registerName register2 dst__2
2193 code__2 = if isFixed register2
2194 then code . mkSeqInstr (FMOV src__2 dst__2)
2199 #endif {- alpha_TARGET_ARCH -}
2201 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2203 #if i386_TARGET_ARCH
2205 -- Floating point assignment to memory
2206 assignMem_FltCode pk addr src
2207 = getRegister src `thenNat` \ reg_src ->
2208 getRegister addr `thenNat` \ reg_addr ->
2209 getNewRegNCG pk `thenNat` \ tmp_src ->
2210 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2211 let r_src = registerName reg_src tmp_src
2212 c_src = registerCode reg_src tmp_src
2213 r_addr = registerName reg_addr tmp_addr
2214 c_addr = registerCode reg_addr tmp_addr
2215 sz = primRepToSize pk
2217 code = c_src `appOL`
2218 -- no need to preserve r_src across the addr computation,
2219 -- since r_src must be a float reg
2220 -- whilst r_addr is an int reg
2223 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2227 -- Floating point assignment to a register/temporary
2228 assignReg_FltCode pk reg src
2229 = getRegisterReg reg `thenNat` \ reg_dst ->
2230 getRegister src `thenNat` \ reg_src ->
2231 getNewRegNCG pk `thenNat` \ tmp ->
2233 r_dst = registerName reg_dst tmp
2234 r_src = registerName reg_src r_dst
2235 c_src = registerCode reg_src r_dst
2237 code = if isFixed reg_src
2238 then c_src `snocOL` GMOV r_src r_dst
2244 #endif {- i386_TARGET_ARCH -}
2246 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2248 #if sparc_TARGET_ARCH
2250 -- Floating point assignment to memory
2251 assignMem_FltCode pk addr src
2252 = getNewRegNCG pk `thenNat` \ tmp1 ->
2253 getAmode addr `thenNat` \ amode ->
2254 getRegister src `thenNat` \ register ->
2256 sz = primRepToSize pk
2257 dst__2 = amodeAddr amode
2259 code1 = amodeCode amode
2260 code2 = registerCode register tmp1
2262 src__2 = registerName register tmp1
2263 pk__2 = registerRep register
2264 sz__2 = primRepToSize pk__2
2266 code__2 = code1 `appOL` code2 `appOL`
2268 then unitOL (ST sz src__2 dst__2)
2269 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2273 -- Floating point assignment to a register/temporary
2274 -- Why is this so bizarrely ugly?
2275 assignReg_FltCode pk reg src
2276 = getRegisterReg reg `thenNat` \ register1 ->
2277 getRegister src `thenNat` \ register2 ->
2279 pk__2 = registerRep register2
2280 sz__2 = primRepToSize pk__2
2282 getNewRegNCG pk__2 `thenNat` \ tmp ->
2284 sz = primRepToSize pk
2285 dst__2 = registerName register1 g0 -- must be Fixed
2286 reg__2 = if pk /= pk__2 then tmp else dst__2
2287 code = registerCode register2 reg__2
2288 src__2 = registerName register2 reg__2
2291 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2292 else if isFixed register2 then
2293 code `snocOL` FMOV sz src__2 dst__2
2299 #endif {- sparc_TARGET_ARCH -}
2301 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2304 %************************************************************************
2306 \subsection{Generating an unconditional branch}
2308 %************************************************************************
2310 We accept two types of targets: an immediate CLabel or a tree that
2311 gets evaluated into a register. Any CLabels which are AsmTemporaries
2312 are assumed to be in the local block of code, close enough for a
2313 branch instruction. Other CLabels are assumed to be far away.
2315 (If applicable) Do not fill the delay slots here; you will confuse the
2319 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2321 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2323 #if alpha_TARGET_ARCH
2325 genJump (StCLbl lbl)
2326 | isAsmTemp lbl = returnInstr (BR target)
2327 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2329 target = ImmCLbl lbl
2332 = getRegister tree `thenNat` \ register ->
2333 getNewRegNCG PtrRep `thenNat` \ tmp ->
2335 dst = registerName register pv
2336 code = registerCode register pv
2337 target = registerName register pv
2339 if isFixed register then
2340 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2342 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2344 #endif {- alpha_TARGET_ARCH -}
2346 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2348 #if i386_TARGET_ARCH
2350 genJump dsts (StInd pk mem)
2351 = getAmode mem `thenNat` \ amode ->
2353 code = amodeCode amode
2354 target = amodeAddr amode
2356 returnNat (code `snocOL` JMP dsts (OpAddr target))
2360 = returnNat (unitOL (JMP dsts (OpImm target)))
2363 = getRegister tree `thenNat` \ register ->
2364 getNewRegNCG PtrRep `thenNat` \ tmp ->
2366 code = registerCode register tmp
2367 target = registerName register tmp
2369 returnNat (code `snocOL` JMP dsts (OpReg target))
2372 target = case imm of Just x -> x
2374 #endif {- i386_TARGET_ARCH -}
2376 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2378 #if sparc_TARGET_ARCH
2380 genJump dsts (StCLbl lbl)
2381 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2382 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2383 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2385 target = ImmCLbl lbl
2388 = getRegister tree `thenNat` \ register ->
2389 getNewRegNCG PtrRep `thenNat` \ tmp ->
2391 code = registerCode register tmp
2392 target = registerName register tmp
2394 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2396 #endif {- sparc_TARGET_ARCH -}
2398 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2401 %************************************************************************
2403 \subsection{Conditional jumps}
2405 %************************************************************************
2407 Conditional jumps are always to local labels, so we can use branch
2408 instructions. We peek at the arguments to decide what kind of
2411 ALPHA: For comparisons with 0, we're laughing, because we can just do
2412 the desired conditional branch.
2414 I386: First, we have to ensure that the condition
2415 codes are set according to the supplied comparison operation.
2417 SPARC: First, we have to ensure that the condition codes are set
2418 according to the supplied comparison operation. We generate slightly
2419 different code for floating point comparisons, because a floating
2420 point operation cannot directly precede a @BF@. We assume the worst
2421 and fill that slot with a @NOP@.
2423 SPARC: Do not fill the delay slots here; you will confuse the register
2428 :: CLabel -- the branch target
2429 -> StixExpr -- the condition on which to branch
2432 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2434 #if alpha_TARGET_ARCH
2436 genCondJump lbl (StPrim op [x, StInt 0])
2437 = getRegister x `thenNat` \ register ->
2438 getNewRegNCG (registerRep register)
2441 code = registerCode register tmp
2442 value = registerName register tmp
2443 pk = registerRep register
2444 target = ImmCLbl lbl
2446 returnSeq code [BI (cmpOp op) value target]
2448 cmpOp CharGtOp = GTT
2450 cmpOp CharEqOp = EQQ
2452 cmpOp CharLtOp = LTT
2461 cmpOp WordGeOp = ALWAYS
2462 cmpOp WordEqOp = EQQ
2464 cmpOp WordLtOp = NEVER
2465 cmpOp WordLeOp = EQQ
2467 cmpOp AddrGeOp = ALWAYS
2468 cmpOp AddrEqOp = EQQ
2470 cmpOp AddrLtOp = NEVER
2471 cmpOp AddrLeOp = EQQ
2473 genCondJump lbl (StPrim op [x, StDouble 0.0])
2474 = getRegister x `thenNat` \ register ->
2475 getNewRegNCG (registerRep register)
2478 code = registerCode register tmp
2479 value = registerName register tmp
2480 pk = registerRep register
2481 target = ImmCLbl lbl
2483 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2485 cmpOp FloatGtOp = GTT
2486 cmpOp FloatGeOp = GE
2487 cmpOp FloatEqOp = EQQ
2488 cmpOp FloatNeOp = NE
2489 cmpOp FloatLtOp = LTT
2490 cmpOp FloatLeOp = LE
2491 cmpOp DoubleGtOp = GTT
2492 cmpOp DoubleGeOp = GE
2493 cmpOp DoubleEqOp = EQQ
2494 cmpOp DoubleNeOp = NE
2495 cmpOp DoubleLtOp = LTT
2496 cmpOp DoubleLeOp = LE
2498 genCondJump lbl (StPrim op [x, y])
2500 = trivialFCode pr instr x y `thenNat` \ register ->
2501 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2503 code = registerCode register tmp
2504 result = registerName register tmp
2505 target = ImmCLbl lbl
2507 returnNat (code . mkSeqInstr (BF cond result target))
2509 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2511 fltCmpOp op = case op of
2525 (instr, cond) = case op of
2526 FloatGtOp -> (FCMP TF LE, EQQ)
2527 FloatGeOp -> (FCMP TF LTT, EQQ)
2528 FloatEqOp -> (FCMP TF EQQ, NE)
2529 FloatNeOp -> (FCMP TF EQQ, EQQ)
2530 FloatLtOp -> (FCMP TF LTT, NE)
2531 FloatLeOp -> (FCMP TF LE, NE)
2532 DoubleGtOp -> (FCMP TF LE, EQQ)
2533 DoubleGeOp -> (FCMP TF LTT, EQQ)
2534 DoubleEqOp -> (FCMP TF EQQ, NE)
2535 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2536 DoubleLtOp -> (FCMP TF LTT, NE)
2537 DoubleLeOp -> (FCMP TF LE, NE)
2539 genCondJump lbl (StPrim op [x, y])
2540 = trivialCode instr x y `thenNat` \ register ->
2541 getNewRegNCG IntRep `thenNat` \ tmp ->
2543 code = registerCode register tmp
2544 result = registerName register tmp
2545 target = ImmCLbl lbl
2547 returnNat (code . mkSeqInstr (BI cond result target))
2549 (instr, cond) = case op of
2550 CharGtOp -> (CMP LE, EQQ)
2551 CharGeOp -> (CMP LTT, EQQ)
2552 CharEqOp -> (CMP EQQ, NE)
2553 CharNeOp -> (CMP EQQ, EQQ)
2554 CharLtOp -> (CMP LTT, NE)
2555 CharLeOp -> (CMP LE, NE)
2556 IntGtOp -> (CMP LE, EQQ)
2557 IntGeOp -> (CMP LTT, EQQ)
2558 IntEqOp -> (CMP EQQ, NE)
2559 IntNeOp -> (CMP EQQ, EQQ)
2560 IntLtOp -> (CMP LTT, NE)
2561 IntLeOp -> (CMP LE, NE)
2562 WordGtOp -> (CMP ULE, EQQ)
2563 WordGeOp -> (CMP ULT, EQQ)
2564 WordEqOp -> (CMP EQQ, NE)
2565 WordNeOp -> (CMP EQQ, EQQ)
2566 WordLtOp -> (CMP ULT, NE)
2567 WordLeOp -> (CMP ULE, NE)
2568 AddrGtOp -> (CMP ULE, EQQ)
2569 AddrGeOp -> (CMP ULT, EQQ)
2570 AddrEqOp -> (CMP EQQ, NE)
2571 AddrNeOp -> (CMP EQQ, EQQ)
2572 AddrLtOp -> (CMP ULT, NE)
2573 AddrLeOp -> (CMP ULE, NE)
2575 #endif {- alpha_TARGET_ARCH -}
2577 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2579 #if i386_TARGET_ARCH
2581 genCondJump lbl bool
2582 = getCondCode bool `thenNat` \ condition ->
2584 code = condCode condition
2585 cond = condName condition
2587 returnNat (code `snocOL` JXX cond lbl)
2589 #endif {- i386_TARGET_ARCH -}
2591 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2593 #if sparc_TARGET_ARCH
2595 genCondJump lbl bool
2596 = getCondCode bool `thenNat` \ condition ->
2598 code = condCode condition
2599 cond = condName condition
2600 target = ImmCLbl lbl
2605 if condFloat condition
2606 then [NOP, BF cond False target, NOP]
2607 else [BI cond False target, NOP]
2611 #endif {- sparc_TARGET_ARCH -}
2613 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2616 %************************************************************************
2618 \subsection{Generating C calls}
2620 %************************************************************************
2622 Now the biggest nightmare---calls. Most of the nastiness is buried in
2623 @get_arg@, which moves the arguments to the correct registers/stack
2624 locations. Apart from that, the code is easy.
2626 (If applicable) Do not fill the delay slots here; you will confuse the
2631 :: (Either FastString StixExpr) -- function to call
2633 -> PrimRep -- type of the result
2634 -> [StixExpr] -- arguments (of mixed type)
2637 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2639 #if alpha_TARGET_ARCH
2641 genCCall fn cconv kind args
2642 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2643 `thenNat` \ ((unused,_), argCode) ->
2645 nRegs = length allArgRegs - length unused
2646 code = asmSeqThen (map ($ []) argCode)
2649 LDA pv (AddrImm (ImmLab (ptext fn))),
2650 JSR ra (AddrReg pv) nRegs,
2651 LDGP gp (AddrReg ra)]
2653 ------------------------
2654 {- Try to get a value into a specific register (or registers) for
2655 a call. The first 6 arguments go into the appropriate
2656 argument register (separate registers for integer and floating
2657 point arguments, but used in lock-step), and the remaining
2658 arguments are dumped to the stack, beginning at 0(sp). Our
2659 first argument is a pair of the list of remaining argument
2660 registers to be assigned for this call and the next stack
2661 offset to use for overflowing arguments. This way,
2662 @get_Arg@ can be applied to all of a call's arguments using
2666 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2667 -> StixTree -- Current argument
2668 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2670 -- We have to use up all of our argument registers first...
2672 get_arg ((iDst,fDst):dsts, offset) arg
2673 = getRegister arg `thenNat` \ register ->
2675 reg = if isFloatingRep pk then fDst else iDst
2676 code = registerCode register reg
2677 src = registerName register reg
2678 pk = registerRep register
2681 if isFloatingRep pk then
2682 ((dsts, offset), if isFixed register then
2683 code . mkSeqInstr (FMOV src fDst)
2686 ((dsts, offset), if isFixed register then
2687 code . mkSeqInstr (OR src (RIReg src) iDst)
2690 -- Once we have run out of argument registers, we move to the
2693 get_arg ([], offset) arg
2694 = getRegister arg `thenNat` \ register ->
2695 getNewRegNCG (registerRep register)
2698 code = registerCode register tmp
2699 src = registerName register tmp
2700 pk = registerRep register
2701 sz = primRepToSize pk
2703 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2705 #endif {- alpha_TARGET_ARCH -}
2707 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2709 #if i386_TARGET_ARCH
2711 genCCall fn cconv ret_rep args
2713 (reverse args) `thenNat` \ sizes_n_codes ->
2714 getDeltaNat `thenNat` \ delta ->
2715 let (sizes, push_codes) = unzip sizes_n_codes
2716 tot_arg_size = sum sizes
2718 -- deal with static vs dynamic call targets
2721 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2723 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2724 ASSERT(case dyn_rep of { L -> True; _ -> False})
2725 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2727 `thenNat` \ callinsns ->
2728 let push_code = concatOL push_codes
2729 call = callinsns `appOL`
2731 -- Deallocate parameters after call for ccall;
2732 -- but not for stdcall (callee does it)
2733 (if cconv == StdCallConv then [] else
2734 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2736 [DELTA (delta + tot_arg_size)]
2739 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2740 returnNat (push_code `appOL` call)
2743 -- function names that begin with '.' are assumed to be special
2744 -- internally generated names like '.mul,' which don't get an
2745 -- underscore prefix
2746 -- ToDo:needed (WDP 96/03) ???
2747 fn_u = unpackFS (unLeft fn)
2750 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2751 | otherwise -- General case
2752 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2754 stdcallsize tot_arg_size
2755 | cconv == StdCallConv = '@':show tot_arg_size
2763 push_arg :: StixExpr{-current argument-}
2764 -> NatM (Int, InstrBlock) -- argsz, code
2767 | is64BitRep arg_rep
2768 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2769 getDeltaNat `thenNat` \ delta ->
2770 setDeltaNat (delta - 8) `thenNat` \ _ ->
2771 let r_lo = VirtualRegI vr_lo
2772 r_hi = getHiVRegFromLo r_lo
2775 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2776 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2779 = get_op arg `thenNat` \ (code, reg, sz) ->
2780 getDeltaNat `thenNat` \ delta ->
2781 arg_size sz `bind` \ size ->
2782 setDeltaNat (delta-size) `thenNat` \ _ ->
2783 if (case sz of DF -> True; F -> True; _ -> False)
2784 then returnNat (size,
2786 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2788 GST sz reg (AddrBaseIndex (Just esp)
2792 else returnNat (size,
2794 PUSH L (OpReg reg) `snocOL`
2798 arg_rep = repOfStixExpr arg
2803 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2806 = getRegister op `thenNat` \ register ->
2807 getNewRegNCG (registerRep register)
2810 code = registerCode register tmp
2811 reg = registerName register tmp
2812 pk = registerRep register
2813 sz = primRepToSize pk
2815 returnNat (code, reg, sz)
2817 #endif {- i386_TARGET_ARCH -}
2819 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2821 #if sparc_TARGET_ARCH
2823 The SPARC calling convention is an absolute
2824 nightmare. The first 6x32 bits of arguments are mapped into
2825 %o0 through %o5, and the remaining arguments are dumped to the
2826 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2828 If we have to put args on the stack, move %o6==%sp down by
2829 the number of words to go on the stack, to ensure there's enough space.
2831 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2832 16 words above the stack pointer is a word for the address of
2833 a structure return value. I use this as a temporary location
2834 for moving values from float to int regs. Certainly it isn't
2835 safe to put anything in the 16 words starting at %sp, since
2836 this area can get trashed at any time due to window overflows
2837 caused by signal handlers.
2839 A final complication (if the above isn't enough) is that
2840 we can't blithely calculate the arguments one by one into
2841 %o0 .. %o5. Consider the following nested calls:
2845 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2846 the inner call will itself use %o0, which trashes the value put there
2847 in preparation for the outer call. Upshot: we need to calculate the
2848 args into temporary regs, and move those to arg regs or onto the
2849 stack only immediately prior to the call proper. Sigh.
2852 genCCall fn cconv kind args
2853 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2855 (argcodes, vregss) = unzip argcode_and_vregs
2856 n_argRegs = length allArgRegs
2857 n_argRegs_used = min (length vregs) n_argRegs
2858 vregs = concat vregss
2860 -- deal with static vs dynamic call targets
2863 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2865 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2866 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2868 `thenNat` \ callinsns ->
2870 argcode = concatOL argcodes
2871 (move_sp_down, move_sp_up)
2872 = let diff = length vregs - n_argRegs
2873 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
2876 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2878 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2880 returnNat (argcode `appOL`
2881 move_sp_down `appOL`
2882 transfer_code `appOL`
2887 -- function names that begin with '.' are assumed to be special
2888 -- internally generated names like '.mul,' which don't get an
2889 -- underscore prefix
2890 -- ToDo:needed (WDP 96/03) ???
2891 fn_static = unLeft fn
2892 fn__2 = case (headFS fn_static) of
2893 '.' -> ImmLit (ftext fn_static)
2894 _ -> ImmLab False (ftext fn_static)
2896 -- move args from the integer vregs into which they have been
2897 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2898 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2900 move_final [] _ offset -- all args done
2903 move_final (v:vs) [] offset -- out of aregs; move to stack
2904 = ST W v (spRel offset)
2905 : move_final vs [] (offset+1)
2907 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2908 = OR False g0 (RIReg v) a
2909 : move_final vs az offset
2911 -- generate code to calculate an argument, and move it into one
2912 -- or two integer vregs.
2913 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2914 arg_to_int_vregs arg
2915 | is64BitRep (repOfStixExpr arg)
2916 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2917 let r_lo = VirtualRegI vr_lo
2918 r_hi = getHiVRegFromLo r_lo
2919 in returnNat (code, [r_hi, r_lo])
2921 = getRegister arg `thenNat` \ register ->
2922 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2923 let code = registerCode register tmp
2924 src = registerName register tmp
2925 pk = registerRep register
2927 -- the value is in src. Get it into 1 or 2 int vregs.
2930 getNewRegNCG WordRep `thenNat` \ v1 ->
2931 getNewRegNCG WordRep `thenNat` \ v2 ->
2934 FMOV DF src f0 `snocOL`
2935 ST F f0 (spRel 16) `snocOL`
2936 LD W (spRel 16) v1 `snocOL`
2937 ST F (fPair f0) (spRel 16) `snocOL`
2943 getNewRegNCG WordRep `thenNat` \ v1 ->
2946 ST F src (spRel 16) `snocOL`
2952 getNewRegNCG WordRep `thenNat` \ v1 ->
2954 code `snocOL` OR False g0 (RIReg src) v1
2958 #endif {- sparc_TARGET_ARCH -}
2960 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2963 %************************************************************************
2965 \subsection{Support bits}
2967 %************************************************************************
2969 %************************************************************************
2971 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2973 %************************************************************************
2975 Turn those condition codes into integers now (when they appear on
2976 the right hand side of an assignment).
2978 (If applicable) Do not fill the delay slots here; you will confuse the
2982 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2984 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2986 #if alpha_TARGET_ARCH
2987 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2988 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2989 #endif {- alpha_TARGET_ARCH -}
2991 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2993 #if i386_TARGET_ARCH
2996 = condIntCode cond x y `thenNat` \ condition ->
2997 getNewRegNCG IntRep `thenNat` \ tmp ->
2999 code = condCode condition
3000 cond = condName condition
3001 code__2 dst = code `appOL` toOL [
3002 SETCC cond (OpReg tmp),
3003 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3004 MOV L (OpReg tmp) (OpReg dst)]
3006 returnNat (Any IntRep code__2)
3009 = getNatLabelNCG `thenNat` \ lbl1 ->
3010 getNatLabelNCG `thenNat` \ lbl2 ->
3011 condFltCode cond x y `thenNat` \ condition ->
3013 code = condCode condition
3014 cond = condName condition
3015 code__2 dst = code `appOL` toOL [
3017 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3020 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3023 returnNat (Any IntRep code__2)
3025 #endif {- i386_TARGET_ARCH -}
3027 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3029 #if sparc_TARGET_ARCH
3031 condIntReg EQQ x (StInt 0)
3032 = getRegister x `thenNat` \ register ->
3033 getNewRegNCG IntRep `thenNat` \ tmp ->
3035 code = registerCode register tmp
3036 src = registerName register tmp
3037 code__2 dst = code `appOL` toOL [
3038 SUB False True g0 (RIReg src) g0,
3039 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3041 returnNat (Any IntRep code__2)
3044 = getRegister x `thenNat` \ register1 ->
3045 getRegister y `thenNat` \ register2 ->
3046 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3047 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3049 code1 = registerCode register1 tmp1
3050 src1 = registerName register1 tmp1
3051 code2 = registerCode register2 tmp2
3052 src2 = registerName register2 tmp2
3053 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3054 XOR False src1 (RIReg src2) dst,
3055 SUB False True g0 (RIReg dst) g0,
3056 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3058 returnNat (Any IntRep code__2)
3060 condIntReg NE x (StInt 0)
3061 = getRegister x `thenNat` \ register ->
3062 getNewRegNCG IntRep `thenNat` \ tmp ->
3064 code = registerCode register tmp
3065 src = registerName register tmp
3066 code__2 dst = code `appOL` toOL [
3067 SUB False True g0 (RIReg src) g0,
3068 ADD True False g0 (RIImm (ImmInt 0)) dst]
3070 returnNat (Any IntRep code__2)
3073 = getRegister x `thenNat` \ register1 ->
3074 getRegister y `thenNat` \ register2 ->
3075 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3076 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3078 code1 = registerCode register1 tmp1
3079 src1 = registerName register1 tmp1
3080 code2 = registerCode register2 tmp2
3081 src2 = registerName register2 tmp2
3082 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3083 XOR False src1 (RIReg src2) dst,
3084 SUB False True g0 (RIReg dst) g0,
3085 ADD True False g0 (RIImm (ImmInt 0)) dst]
3087 returnNat (Any IntRep code__2)
3090 = getNatLabelNCG `thenNat` \ lbl1 ->
3091 getNatLabelNCG `thenNat` \ lbl2 ->
3092 condIntCode cond x y `thenNat` \ condition ->
3094 code = condCode condition
3095 cond = condName condition
3096 code__2 dst = code `appOL` toOL [
3097 BI cond False (ImmCLbl lbl1), NOP,
3098 OR False g0 (RIImm (ImmInt 0)) dst,
3099 BI ALWAYS False (ImmCLbl lbl2), NOP,
3101 OR False g0 (RIImm (ImmInt 1)) dst,
3104 returnNat (Any IntRep code__2)
3107 = getNatLabelNCG `thenNat` \ lbl1 ->
3108 getNatLabelNCG `thenNat` \ lbl2 ->
3109 condFltCode cond x y `thenNat` \ condition ->
3111 code = condCode condition
3112 cond = condName condition
3113 code__2 dst = code `appOL` toOL [
3115 BF cond False (ImmCLbl lbl1), NOP,
3116 OR False g0 (RIImm (ImmInt 0)) dst,
3117 BI ALWAYS False (ImmCLbl lbl2), NOP,
3119 OR False g0 (RIImm (ImmInt 1)) dst,
3122 returnNat (Any IntRep code__2)
3124 #endif {- sparc_TARGET_ARCH -}
3126 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3129 %************************************************************************
3131 \subsubsection{@trivial*Code@: deal with trivial instructions}
3133 %************************************************************************
3135 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3136 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3137 for constants on the right hand side, because that's where the generic
3138 optimizer will have put them.
3140 Similarly, for unary instructions, we don't have to worry about
3141 matching an StInt as the argument, because genericOpt will already
3142 have handled the constant-folding.
3146 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3147 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3148 -> Maybe (Operand -> Operand -> Instr)
3149 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3151 -> StixExpr -> StixExpr -- the two arguments
3156 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3157 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3158 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3160 -> StixExpr -> StixExpr -- the two arguments
3164 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3165 ,IF_ARCH_i386 ((Operand -> Instr)
3166 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3168 -> StixExpr -- the one argument
3173 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3174 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3175 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3177 -> StixExpr -- the one argument
3180 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3182 #if alpha_TARGET_ARCH
3184 trivialCode instr x (StInt y)
3186 = getRegister x `thenNat` \ register ->
3187 getNewRegNCG IntRep `thenNat` \ tmp ->
3189 code = registerCode register tmp
3190 src1 = registerName register tmp
3191 src2 = ImmInt (fromInteger y)
3192 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3194 returnNat (Any IntRep code__2)
3196 trivialCode instr x y
3197 = getRegister x `thenNat` \ register1 ->
3198 getRegister y `thenNat` \ register2 ->
3199 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3200 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3202 code1 = registerCode register1 tmp1 []
3203 src1 = registerName register1 tmp1
3204 code2 = registerCode register2 tmp2 []
3205 src2 = registerName register2 tmp2
3206 code__2 dst = asmSeqThen [code1, code2] .
3207 mkSeqInstr (instr src1 (RIReg src2) dst)
3209 returnNat (Any IntRep code__2)
3212 trivialUCode instr x
3213 = getRegister x `thenNat` \ register ->
3214 getNewRegNCG IntRep `thenNat` \ tmp ->
3216 code = registerCode register tmp
3217 src = registerName register tmp
3218 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3220 returnNat (Any IntRep code__2)
3223 trivialFCode _ instr x y
3224 = getRegister x `thenNat` \ register1 ->
3225 getRegister y `thenNat` \ register2 ->
3226 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3227 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3229 code1 = registerCode register1 tmp1
3230 src1 = registerName register1 tmp1
3232 code2 = registerCode register2 tmp2
3233 src2 = registerName register2 tmp2
3235 code__2 dst = asmSeqThen [code1 [], code2 []] .
3236 mkSeqInstr (instr src1 src2 dst)
3238 returnNat (Any DoubleRep code__2)
3240 trivialUFCode _ instr x
3241 = getRegister x `thenNat` \ register ->
3242 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3244 code = registerCode register tmp
3245 src = registerName register tmp
3246 code__2 dst = code . mkSeqInstr (instr src dst)
3248 returnNat (Any DoubleRep code__2)
3250 #endif {- alpha_TARGET_ARCH -}
3252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3254 #if i386_TARGET_ARCH
3256 The Rules of the Game are:
3258 * You cannot assume anything about the destination register dst;
3259 it may be anything, including a fixed reg.
3261 * You may compute an operand into a fixed reg, but you may not
3262 subsequently change the contents of that fixed reg. If you
3263 want to do so, first copy the value either to a temporary
3264 or into dst. You are free to modify dst even if it happens
3265 to be a fixed reg -- that's not your problem.
3267 * You cannot assume that a fixed reg will stay live over an
3268 arbitrary computation. The same applies to the dst reg.
3270 * Temporary regs obtained from getNewRegNCG are distinct from
3271 each other and from all other regs, and stay live over
3272 arbitrary computations.
3276 trivialCode instr maybe_revinstr a b
3279 = getRegister a `thenNat` \ rega ->
3282 then registerCode rega dst `bind` \ code_a ->
3284 instr (OpImm imm_b) (OpReg dst)
3285 else registerCodeF rega `bind` \ code_a ->
3286 registerNameF rega `bind` \ r_a ->
3288 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3289 instr (OpImm imm_b) (OpReg dst)
3291 returnNat (Any IntRep mkcode)
3294 = getRegister b `thenNat` \ regb ->
3295 getNewRegNCG IntRep `thenNat` \ tmp ->
3296 let revinstr_avail = maybeToBool maybe_revinstr
3297 revinstr = case maybe_revinstr of Just ri -> ri
3301 then registerCode regb dst `bind` \ code_b ->
3303 revinstr (OpImm imm_a) (OpReg dst)
3304 else registerCodeF regb `bind` \ code_b ->
3305 registerNameF regb `bind` \ r_b ->
3307 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3308 revinstr (OpImm imm_a) (OpReg dst)
3312 then registerCode regb tmp `bind` \ code_b ->
3314 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3315 instr (OpReg tmp) (OpReg dst)
3316 else registerCodeF regb `bind` \ code_b ->
3317 registerNameF regb `bind` \ r_b ->
3319 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3320 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3321 instr (OpReg tmp) (OpReg dst)
3323 returnNat (Any IntRep mkcode)
3326 = getRegister a `thenNat` \ rega ->
3327 getRegister b `thenNat` \ regb ->
3328 getNewRegNCG IntRep `thenNat` \ tmp ->
3330 = case (isAny rega, isAny regb) of
3332 -> registerCode regb tmp `bind` \ code_b ->
3333 registerCode rega dst `bind` \ code_a ->
3336 instr (OpReg tmp) (OpReg dst)
3338 -> registerCode rega tmp `bind` \ code_a ->
3339 registerCodeF regb `bind` \ code_b ->
3340 registerNameF regb `bind` \ r_b ->
3343 instr (OpReg r_b) (OpReg tmp) `snocOL`
3344 MOV L (OpReg tmp) (OpReg dst)
3346 -> registerCode regb tmp `bind` \ code_b ->
3347 registerCodeF rega `bind` \ code_a ->
3348 registerNameF rega `bind` \ r_a ->
3351 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3352 instr (OpReg tmp) (OpReg dst)
3354 -> registerCodeF rega `bind` \ code_a ->
3355 registerNameF rega `bind` \ r_a ->
3356 registerCodeF regb `bind` \ code_b ->
3357 registerNameF regb `bind` \ r_b ->
3359 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3361 instr (OpReg r_b) (OpReg tmp) `snocOL`
3362 MOV L (OpReg tmp) (OpReg dst)
3364 returnNat (Any IntRep mkcode)
3367 maybe_imm_a = maybeImm a
3368 is_imm_a = maybeToBool maybe_imm_a
3369 imm_a = case maybe_imm_a of Just imm -> imm
3371 maybe_imm_b = maybeImm b
3372 is_imm_b = maybeToBool maybe_imm_b
3373 imm_b = case maybe_imm_b of Just imm -> imm
3377 trivialUCode instr x
3378 = getRegister x `thenNat` \ register ->
3380 code__2 dst = let code = registerCode register dst
3381 src = registerName register dst
3383 if isFixed register && dst /= src
3384 then toOL [MOV L (OpReg src) (OpReg dst),
3386 else unitOL (instr (OpReg src))
3388 returnNat (Any IntRep code__2)
3391 trivialFCode pk instr x y
3392 = getRegister x `thenNat` \ register1 ->
3393 getRegister y `thenNat` \ register2 ->
3394 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3395 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3397 code1 = registerCode register1 tmp1
3398 src1 = registerName register1 tmp1
3400 code2 = registerCode register2 tmp2
3401 src2 = registerName register2 tmp2
3404 -- treat the common case specially: both operands in
3406 | isAny register1 && isAny register2
3409 instr (primRepToSize pk) src1 src2 dst
3411 -- be paranoid (and inefficient)
3413 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3415 instr (primRepToSize pk) tmp1 src2 dst
3417 returnNat (Any pk code__2)
3421 trivialUFCode pk instr x
3422 = getRegister x `thenNat` \ register ->
3423 getNewRegNCG pk `thenNat` \ tmp ->
3425 code = registerCode register tmp
3426 src = registerName register tmp
3427 code__2 dst = code `snocOL` instr src dst
3429 returnNat (Any pk code__2)
3431 #endif {- i386_TARGET_ARCH -}
3433 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3435 #if sparc_TARGET_ARCH
3437 trivialCode instr x (StInt y)
3439 = getRegister x `thenNat` \ register ->
3440 getNewRegNCG IntRep `thenNat` \ tmp ->
3442 code = registerCode register tmp
3443 src1 = registerName register tmp
3444 src2 = ImmInt (fromInteger y)
3445 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3447 returnNat (Any IntRep code__2)
3449 trivialCode instr x y
3450 = getRegister x `thenNat` \ register1 ->
3451 getRegister y `thenNat` \ register2 ->
3452 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3453 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3455 code1 = registerCode register1 tmp1
3456 src1 = registerName register1 tmp1
3457 code2 = registerCode register2 tmp2
3458 src2 = registerName register2 tmp2
3459 code__2 dst = code1 `appOL` code2 `snocOL`
3460 instr src1 (RIReg src2) dst
3462 returnNat (Any IntRep code__2)
3465 trivialFCode pk instr x y
3466 = getRegister x `thenNat` \ register1 ->
3467 getRegister y `thenNat` \ register2 ->
3468 getNewRegNCG (registerRep register1)
3470 getNewRegNCG (registerRep register2)
3472 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3474 promote x = FxTOy F DF x tmp
3476 pk1 = registerRep register1
3477 code1 = registerCode register1 tmp1
3478 src1 = registerName register1 tmp1
3480 pk2 = registerRep register2
3481 code2 = registerCode register2 tmp2
3482 src2 = registerName register2 tmp2
3486 code1 `appOL` code2 `snocOL`
3487 instr (primRepToSize pk) src1 src2 dst
3488 else if pk1 == FloatRep then
3489 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3490 instr DF tmp src2 dst
3492 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3493 instr DF src1 tmp dst
3495 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3498 trivialUCode instr x
3499 = getRegister x `thenNat` \ register ->
3500 getNewRegNCG IntRep `thenNat` \ tmp ->
3502 code = registerCode register tmp
3503 src = registerName register tmp
3504 code__2 dst = code `snocOL` instr (RIReg src) dst
3506 returnNat (Any IntRep code__2)
3509 trivialUFCode pk instr x
3510 = getRegister x `thenNat` \ register ->
3511 getNewRegNCG pk `thenNat` \ tmp ->
3513 code = registerCode register tmp
3514 src = registerName register tmp
3515 code__2 dst = code `snocOL` instr src dst
3517 returnNat (Any pk code__2)
3519 #endif {- sparc_TARGET_ARCH -}
3521 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3524 %************************************************************************
3526 \subsubsection{Coercing to/from integer/floating-point...}
3528 %************************************************************************
3530 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3531 conversions. We have to store temporaries in memory to move
3532 between the integer and the floating point register sets.
3534 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3535 pretend, on sparc at least, that double and float regs are seperate
3536 kinds, so the value has to be computed into one kind before being
3537 explicitly "converted" to live in the other kind.
3540 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3541 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3543 coerceDbl2Flt :: StixExpr -> NatM Register
3544 coerceFlt2Dbl :: StixExpr -> NatM Register
3548 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3550 #if alpha_TARGET_ARCH
3553 = getRegister x `thenNat` \ register ->
3554 getNewRegNCG IntRep `thenNat` \ reg ->
3556 code = registerCode register reg
3557 src = registerName register reg
3559 code__2 dst = code . mkSeqInstrs [
3561 LD TF dst (spRel 0),
3564 returnNat (Any DoubleRep code__2)
3568 = getRegister x `thenNat` \ register ->
3569 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3571 code = registerCode register tmp
3572 src = registerName register tmp
3574 code__2 dst = code . mkSeqInstrs [
3576 ST TF tmp (spRel 0),
3579 returnNat (Any IntRep code__2)
3581 #endif {- alpha_TARGET_ARCH -}
3583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3585 #if i386_TARGET_ARCH
3588 = getRegister x `thenNat` \ register ->
3589 getNewRegNCG IntRep `thenNat` \ reg ->
3591 code = registerCode register reg
3592 src = registerName register reg
3593 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3594 code__2 dst = code `snocOL` opc src dst
3596 returnNat (Any pk code__2)
3599 coerceFP2Int fprep x
3600 = getRegister x `thenNat` \ register ->
3601 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3603 code = registerCode register tmp
3604 src = registerName register tmp
3605 pk = registerRep register
3607 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3608 code__2 dst = code `snocOL` opc src dst
3610 returnNat (Any IntRep code__2)
3613 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3614 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3616 #endif {- i386_TARGET_ARCH -}
3618 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3620 #if sparc_TARGET_ARCH
3623 = getRegister x `thenNat` \ register ->
3624 getNewRegNCG IntRep `thenNat` \ reg ->
3626 code = registerCode register reg
3627 src = registerName register reg
3629 code__2 dst = code `appOL` toOL [
3630 ST W src (spRel (-2)),
3631 LD W (spRel (-2)) dst,
3632 FxTOy W (primRepToSize pk) dst dst]
3634 returnNat (Any pk code__2)
3637 coerceFP2Int fprep x
3638 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3639 getRegister x `thenNat` \ register ->
3640 getNewRegNCG fprep `thenNat` \ reg ->
3641 getNewRegNCG FloatRep `thenNat` \ tmp ->
3643 code = registerCode register reg
3644 src = registerName register reg
3645 code__2 dst = code `appOL` toOL [
3646 FxTOy (primRepToSize fprep) W src tmp,
3647 ST W tmp (spRel (-2)),
3648 LD W (spRel (-2)) dst]
3650 returnNat (Any IntRep code__2)
3654 = getRegister x `thenNat` \ register ->
3655 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3656 let code = registerCode register tmp
3657 src = registerName register tmp
3659 returnNat (Any FloatRep
3660 (\dst -> code `snocOL` FxTOy DF F src dst))
3664 = getRegister x `thenNat` \ register ->
3665 getNewRegNCG FloatRep `thenNat` \ tmp ->
3666 let code = registerCode register tmp
3667 src = registerName register tmp
3669 returnNat (Any DoubleRep
3670 (\dst -> code `snocOL` FxTOy F DF src dst))
3672 #endif {- sparc_TARGET_ARCH -}
3674 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -