2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import Unique ( Unique )
18 import MachMisc -- may differ per-platform
20 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
21 snocOL, consOL, concatOL )
22 import MachOp ( MachOp(..), pprMachOp )
23 import AbsCUtils ( magicIdPrimRep )
24 import PprAbsC ( pprMagicId )
25 import ForeignCall ( CCallConv(..) )
26 import CLabel ( CLabel, labelDynamic )
27 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
28 import CLabel ( isAsmTemp )
30 import Maybes ( maybeToBool )
31 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
32 getPrimRepArrayElemSize )
33 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
34 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
35 DestInfo, hasDestInfo,
36 pprStixExpr, repOfStixExpr,
38 NatM, thenNat, returnNat, mapNat,
39 mapAndUnzipNat, mapAccumLNat,
40 getDeltaNat, setDeltaNat, getUniqueNat,
45 import Outputable ( panic, pprPanic, showSDoc )
46 import qualified Outputable
47 import CmdLineOpts ( opt_Static )
48 import Stix ( pprStixStmt )
51 import IOExts ( trace )
52 import Outputable ( assertPanic )
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 * getPrimRepArrayElemSize 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 (getPrimRepArrayElemSize 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 getPrimRepArrayElemSize 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 * getPrimRepArrayElemSize 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
868 MO_NatU_to_NatS -> conversionNop IntRep x
869 MO_NatS_to_NatU -> conversionNop WordRep x
870 MO_NatP_to_NatU -> conversionNop WordRep x
871 MO_NatU_to_NatP -> conversionNop PtrRep x
872 MO_NatS_to_NatP -> conversionNop PtrRep x
873 MO_NatP_to_NatS -> conversionNop IntRep x
875 MO_Dbl_to_Flt -> conversionNop FloatRep x
876 MO_Flt_to_Dbl -> conversionNop DoubleRep x
878 -- sign-extending widenings
879 MO_8U_to_NatU -> integerExtend False 24 x
880 MO_8S_to_NatS -> integerExtend True 24 x
881 MO_16U_to_NatU -> integerExtend False 16 x
882 MO_16S_to_NatS -> integerExtend True 16 x
883 MO_8U_to_32U -> integerExtend False 24 x
887 (if is_float_op then demote else id)
888 (StCall (Left fn) CCallConv DoubleRep
889 [(if is_float_op then promote else id) x])
892 integerExtend signed nBits x
894 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
895 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
898 conversionNop new_rep expr
899 = getRegister expr `thenNat` \ e_code ->
900 returnNat (swizzleRegisterRep e_code new_rep)
902 promote x = StMachOp MO_Flt_to_Dbl [x]
903 demote x = StMachOp MO_Dbl_to_Flt [x]
906 MO_Flt_Exp -> (True, FSLIT("exp"))
907 MO_Flt_Log -> (True, FSLIT("log"))
909 MO_Flt_Asin -> (True, FSLIT("asin"))
910 MO_Flt_Acos -> (True, FSLIT("acos"))
911 MO_Flt_Atan -> (True, FSLIT("atan"))
913 MO_Flt_Sinh -> (True, FSLIT("sinh"))
914 MO_Flt_Cosh -> (True, FSLIT("cosh"))
915 MO_Flt_Tanh -> (True, FSLIT("tanh"))
917 MO_Dbl_Exp -> (False, FSLIT("exp"))
918 MO_Dbl_Log -> (False, FSLIT("log"))
920 MO_Dbl_Asin -> (False, FSLIT("asin"))
921 MO_Dbl_Acos -> (False, FSLIT("acos"))
922 MO_Dbl_Atan -> (False, FSLIT("atan"))
924 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
925 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
926 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
928 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
932 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
934 MO_32U_Gt -> condIntReg GTT x y
935 MO_32U_Ge -> condIntReg GE x y
936 MO_32U_Eq -> condIntReg EQQ x y
937 MO_32U_Ne -> condIntReg NE x y
938 MO_32U_Lt -> condIntReg LTT x y
939 MO_32U_Le -> condIntReg LE x y
941 MO_Nat_Eq -> condIntReg EQQ x y
942 MO_Nat_Ne -> condIntReg NE x y
944 MO_NatS_Gt -> condIntReg GTT x y
945 MO_NatS_Ge -> condIntReg GE x y
946 MO_NatS_Lt -> condIntReg LTT x y
947 MO_NatS_Le -> condIntReg LE x y
949 MO_NatU_Gt -> condIntReg GU x y
950 MO_NatU_Ge -> condIntReg GEU x y
951 MO_NatU_Lt -> condIntReg LU x y
952 MO_NatU_Le -> condIntReg LEU x y
954 MO_Flt_Gt -> condFltReg GTT x y
955 MO_Flt_Ge -> condFltReg GE x y
956 MO_Flt_Eq -> condFltReg EQQ x y
957 MO_Flt_Ne -> condFltReg NE x y
958 MO_Flt_Lt -> condFltReg LTT x y
959 MO_Flt_Le -> condFltReg LE x y
961 MO_Dbl_Gt -> condFltReg GTT x y
962 MO_Dbl_Ge -> condFltReg GE x y
963 MO_Dbl_Eq -> condFltReg EQQ x y
964 MO_Dbl_Ne -> condFltReg NE x y
965 MO_Dbl_Lt -> condFltReg LTT x y
966 MO_Dbl_Le -> condFltReg LE x y
968 MO_Nat_Add -> add_code L x y
969 MO_Nat_Sub -> sub_code L x y
970 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
971 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
972 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
973 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
974 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
975 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
976 MO_NatS_MulMayOflo -> imulMayOflo x y
978 MO_Flt_Add -> trivialFCode FloatRep GADD x y
979 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
980 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
981 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
983 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
984 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
985 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
986 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
988 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
989 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
990 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
992 {- Shift ops on x86s have constraints on their source, it
993 either has to be Imm, CL or 1
994 => trivialCode's is not restrictive enough (sigh.)
996 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
997 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
998 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1000 MO_Flt_Pwr -> getRegister (demote
1001 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1002 [promote x, promote y])
1004 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1006 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1008 promote x = StMachOp MO_Flt_to_Dbl [x]
1009 demote x = StMachOp MO_Dbl_to_Flt [x]
1011 --------------------
1012 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1014 = getNewRegNCG IntRep `thenNat` \ t1 ->
1015 getNewRegNCG IntRep `thenNat` \ t2 ->
1016 getNewRegNCG IntRep `thenNat` \ res_lo ->
1017 getNewRegNCG IntRep `thenNat` \ res_hi ->
1018 getRegister a1 `thenNat` \ reg1 ->
1019 getRegister a2 `thenNat` \ reg2 ->
1020 let code1 = registerCode reg1 t1
1021 code2 = registerCode reg2 t2
1022 src1 = registerName reg1 t1
1023 src2 = registerName reg2 t2
1024 code dst = code1 `appOL` code2 `appOL`
1026 MOV L (OpReg src1) (OpReg res_hi),
1027 MOV L (OpReg src2) (OpReg res_lo),
1028 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1029 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1030 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1031 MOV L (OpReg res_lo) (OpReg dst)
1032 -- dst==0 if high part == sign extended low part
1035 returnNat (Any IntRep code)
1037 --------------------
1038 shift_code :: (Imm -> Operand -> Instr)
1043 {- Case1: shift length as immediate -}
1044 -- Code is the same as the first eq. for trivialCode -- sigh.
1045 shift_code instr x y{-amount-}
1047 = getRegister x `thenNat` \ regx ->
1050 then registerCodeA regx dst `bind` \ code_x ->
1052 instr imm__2 (OpReg dst)
1053 else registerCodeF regx `bind` \ code_x ->
1054 registerNameF regx `bind` \ r_x ->
1056 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1057 instr imm__2 (OpReg dst)
1059 returnNat (Any IntRep mkcode)
1062 imm__2 = case imm of Just x -> x
1064 {- Case2: shift length is complex (non-immediate) -}
1065 -- Since ECX is always used as a spill temporary, we can't
1066 -- use it here to do non-immediate shifts. No big deal --
1067 -- they are only very rare, and we can use an equivalent
1068 -- test-and-jump sequence which doesn't use ECX.
1069 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1070 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1071 shift_code instr x y{-amount-}
1072 = getRegister x `thenNat` \ register1 ->
1073 getRegister y `thenNat` \ register2 ->
1074 getNatLabelNCG `thenNat` \ lbl_test3 ->
1075 getNatLabelNCG `thenNat` \ lbl_test2 ->
1076 getNatLabelNCG `thenNat` \ lbl_test1 ->
1077 getNatLabelNCG `thenNat` \ lbl_test0 ->
1078 getNatLabelNCG `thenNat` \ lbl_after ->
1079 getNewRegNCG IntRep `thenNat` \ tmp ->
1081 = let src_val = registerName register1 dst
1082 code_val = registerCode register1 dst
1083 src_amt = registerName register2 tmp
1084 code_amt = registerCode register2 tmp
1089 MOV L (OpReg src_amt) r_tmp `appOL`
1091 MOV L (OpReg src_val) r_dst `appOL`
1093 COMMENT (mkFastString "begin shift sequence"),
1094 MOV L (OpReg src_val) r_dst,
1095 MOV L (OpReg src_amt) r_tmp,
1097 BT L (ImmInt 4) r_tmp,
1099 instr (ImmInt 16) r_dst,
1102 BT L (ImmInt 3) r_tmp,
1104 instr (ImmInt 8) r_dst,
1107 BT L (ImmInt 2) r_tmp,
1109 instr (ImmInt 4) r_dst,
1112 BT L (ImmInt 1) r_tmp,
1114 instr (ImmInt 2) r_dst,
1117 BT L (ImmInt 0) r_tmp,
1119 instr (ImmInt 1) r_dst,
1122 COMMENT (mkFastString "end shift sequence")
1125 returnNat (Any IntRep code__2)
1127 --------------------
1128 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1130 add_code sz x (StInt y)
1131 = getRegister x `thenNat` \ register ->
1132 getNewRegNCG IntRep `thenNat` \ tmp ->
1134 code = registerCode register tmp
1135 src1 = registerName register tmp
1136 src2 = ImmInt (fromInteger y)
1139 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1142 returnNat (Any IntRep code__2)
1144 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1146 --------------------
1147 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1149 sub_code sz x (StInt y)
1150 = getRegister x `thenNat` \ register ->
1151 getNewRegNCG IntRep `thenNat` \ tmp ->
1153 code = registerCode register tmp
1154 src1 = registerName register tmp
1155 src2 = ImmInt (-(fromInteger y))
1158 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1161 returnNat (Any IntRep code__2)
1163 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1165 getRegister (StInd pk mem)
1166 | not (is64BitRep pk)
1167 = getAmode mem `thenNat` \ amode ->
1169 code = amodeCode amode
1170 src = amodeAddr amode
1171 size = primRepToSize pk
1172 code__2 dst = code `snocOL`
1173 if pk == DoubleRep || pk == FloatRep
1174 then GLD size src dst
1182 (OpAddr src) (OpReg dst)
1184 returnNat (Any pk code__2)
1186 getRegister (StInt i)
1188 src = ImmInt (fromInteger i)
1191 = unitOL (XOR L (OpReg dst) (OpReg dst))
1193 = unitOL (MOV L (OpImm src) (OpReg dst))
1195 returnNat (Any IntRep code)
1199 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1201 returnNat (Any PtrRep code)
1203 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1206 imm__2 = case imm of Just x -> x
1208 #endif {- i386_TARGET_ARCH -}
1210 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1212 #if sparc_TARGET_ARCH
1214 getRegister (StFloat d)
1215 = getNatLabelNCG `thenNat` \ lbl ->
1216 getNewRegNCG PtrRep `thenNat` \ tmp ->
1217 let code dst = toOL [
1218 SEGMENT DataSegment,
1220 DATA F [ImmFloat d],
1221 SEGMENT TextSegment,
1222 SETHI (HI (ImmCLbl lbl)) tmp,
1223 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1225 returnNat (Any FloatRep code)
1227 getRegister (StDouble d)
1228 = getNatLabelNCG `thenNat` \ lbl ->
1229 getNewRegNCG PtrRep `thenNat` \ tmp ->
1230 let code dst = toOL [
1231 SEGMENT DataSegment,
1233 DATA DF [ImmDouble d],
1234 SEGMENT TextSegment,
1235 SETHI (HI (ImmCLbl lbl)) tmp,
1236 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1238 returnNat (Any DoubleRep code)
1241 getRegister (StMachOp mop [x]) -- unary PrimOps
1243 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1244 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1245 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1247 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1248 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1250 MO_Dbl_to_Flt -> coerceDbl2Flt x
1251 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1253 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1254 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1255 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1256 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1258 -- Conversions which are a nop on sparc
1259 MO_32U_to_NatS -> conversionNop IntRep x
1260 MO_NatS_to_32U -> conversionNop WordRep x
1262 MO_NatU_to_NatS -> conversionNop IntRep x
1263 MO_NatS_to_NatU -> conversionNop WordRep x
1264 MO_NatP_to_NatU -> conversionNop WordRep x
1265 MO_NatU_to_NatP -> conversionNop PtrRep x
1266 MO_NatS_to_NatP -> conversionNop PtrRep x
1267 MO_NatP_to_NatS -> conversionNop IntRep x
1269 -- sign-extending widenings
1270 MO_8U_to_32U -> integerExtend False 24 x
1271 MO_8U_to_NatU -> integerExtend False 24 x
1272 MO_8S_to_NatS -> integerExtend True 24 x
1273 MO_16U_to_NatU -> integerExtend False 16 x
1274 MO_16S_to_NatS -> integerExtend True 16 x
1277 let fixed_x = if is_float_op -- promote to double
1278 then StMachOp MO_Flt_to_Dbl [x]
1281 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1283 integerExtend signed nBits x
1285 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1286 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1288 conversionNop new_rep expr
1289 = getRegister expr `thenNat` \ e_code ->
1290 returnNat (swizzleRegisterRep e_code new_rep)
1294 MO_Flt_Exp -> (True, FSLIT("exp"))
1295 MO_Flt_Log -> (True, FSLIT("log"))
1296 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1298 MO_Flt_Sin -> (True, FSLIT("sin"))
1299 MO_Flt_Cos -> (True, FSLIT("cos"))
1300 MO_Flt_Tan -> (True, FSLIT("tan"))
1302 MO_Flt_Asin -> (True, FSLIT("asin"))
1303 MO_Flt_Acos -> (True, FSLIT("acos"))
1304 MO_Flt_Atan -> (True, FSLIT("atan"))
1306 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1307 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1308 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1310 MO_Dbl_Exp -> (False, FSLIT("exp"))
1311 MO_Dbl_Log -> (False, FSLIT("log"))
1312 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1314 MO_Dbl_Sin -> (False, FSLIT("sin"))
1315 MO_Dbl_Cos -> (False, FSLIT("cos"))
1316 MO_Dbl_Tan -> (False, FSLIT("tan"))
1318 MO_Dbl_Asin -> (False, FSLIT("asin"))
1319 MO_Dbl_Acos -> (False, FSLIT("acos"))
1320 MO_Dbl_Atan -> (False, FSLIT("atan"))
1322 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1323 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1324 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1326 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1330 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1332 MO_32U_Gt -> condIntReg GTT x y
1333 MO_32U_Ge -> condIntReg GE x y
1334 MO_32U_Eq -> condIntReg EQQ x y
1335 MO_32U_Ne -> condIntReg NE x y
1336 MO_32U_Lt -> condIntReg LTT x y
1337 MO_32U_Le -> condIntReg LE x y
1339 MO_Nat_Eq -> condIntReg EQQ x y
1340 MO_Nat_Ne -> condIntReg NE x y
1342 MO_NatS_Gt -> condIntReg GTT x y
1343 MO_NatS_Ge -> condIntReg GE x y
1344 MO_NatS_Lt -> condIntReg LTT x y
1345 MO_NatS_Le -> condIntReg LE x y
1347 MO_NatU_Gt -> condIntReg GU x y
1348 MO_NatU_Ge -> condIntReg GEU x y
1349 MO_NatU_Lt -> condIntReg LU x y
1350 MO_NatU_Le -> condIntReg LEU x y
1352 MO_Flt_Gt -> condFltReg GTT x y
1353 MO_Flt_Ge -> condFltReg GE x y
1354 MO_Flt_Eq -> condFltReg EQQ x y
1355 MO_Flt_Ne -> condFltReg NE x y
1356 MO_Flt_Lt -> condFltReg LTT x y
1357 MO_Flt_Le -> condFltReg LE x y
1359 MO_Dbl_Gt -> condFltReg GTT x y
1360 MO_Dbl_Ge -> condFltReg GE x y
1361 MO_Dbl_Eq -> condFltReg EQQ x y
1362 MO_Dbl_Ne -> condFltReg NE x y
1363 MO_Dbl_Lt -> condFltReg LTT x y
1364 MO_Dbl_Le -> condFltReg LE x y
1366 MO_Nat_Add -> trivialCode (ADD False False) x y
1367 MO_Nat_Sub -> trivialCode (SUB False False) x y
1369 MO_NatS_Mul -> trivialCode (SMUL False) x y
1370 MO_NatU_Mul -> trivialCode (UMUL False) x y
1371 MO_NatS_MulMayOflo -> imulMayOflo x y
1373 -- ToDo: teach about V8+ SPARC div instructions
1374 MO_NatS_Quot -> idiv FSLIT(".div") x y
1375 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1376 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1377 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1379 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1380 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1381 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1382 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1384 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1385 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1386 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1387 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1389 MO_Nat_And -> trivialCode (AND False) x y
1390 MO_Nat_Or -> trivialCode (OR False) x y
1391 MO_Nat_Xor -> trivialCode (XOR False) x y
1393 MO_Nat_Shl -> trivialCode SLL x y
1394 MO_Nat_Shr -> trivialCode SRL x y
1395 MO_Nat_Sar -> trivialCode SRA x y
1397 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1398 [promote x, promote y])
1399 where promote x = StMachOp MO_Flt_to_Dbl [x]
1400 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1403 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1405 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1407 --------------------
1408 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1410 = getNewRegNCG IntRep `thenNat` \ t1 ->
1411 getNewRegNCG IntRep `thenNat` \ t2 ->
1412 getNewRegNCG IntRep `thenNat` \ res_lo ->
1413 getNewRegNCG IntRep `thenNat` \ res_hi ->
1414 getRegister a1 `thenNat` \ reg1 ->
1415 getRegister a2 `thenNat` \ reg2 ->
1416 let code1 = registerCode reg1 t1
1417 code2 = registerCode reg2 t2
1418 src1 = registerName reg1 t1
1419 src2 = registerName reg2 t2
1420 code dst = code1 `appOL` code2 `appOL`
1422 SMUL False src1 (RIReg src2) res_lo,
1424 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1425 SUB False False res_lo (RIReg res_hi) dst
1428 returnNat (Any IntRep code)
1430 getRegister (StInd pk mem)
1431 = getAmode mem `thenNat` \ amode ->
1433 code = amodeCode amode
1434 src = amodeAddr amode
1435 size = primRepToSize pk
1436 code__2 dst = code `snocOL` LD size src dst
1438 returnNat (Any pk code__2)
1440 getRegister (StInt i)
1443 src = ImmInt (fromInteger i)
1444 code dst = unitOL (OR False g0 (RIImm src) dst)
1446 returnNat (Any IntRep code)
1452 SETHI (HI imm__2) dst,
1453 OR False dst (RIImm (LO imm__2)) dst]
1455 returnNat (Any PtrRep code)
1457 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1460 imm__2 = case imm of Just x -> x
1462 #endif {- sparc_TARGET_ARCH -}
1464 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1468 %************************************************************************
1470 \subsection{The @Amode@ type}
1472 %************************************************************************
1474 @Amode@s: Memory addressing modes passed up the tree.
1476 data Amode = Amode MachRegsAddr InstrBlock
1478 amodeAddr (Amode addr _) = addr
1479 amodeCode (Amode _ code) = code
1482 Now, given a tree (the argument to an StInd) that references memory,
1483 produce a suitable addressing mode.
1485 A Rule of the Game (tm) for Amodes: use of the addr bit must
1486 immediately follow use of the code part, since the code part puts
1487 values in registers which the addr then refers to. So you can't put
1488 anything in between, lest it overwrite some of those registers. If
1489 you need to do some other computation between the code part and use of
1490 the addr bit, first store the effective address from the amode in a
1491 temporary, then do the other computation, and then use the temporary:
1495 ... other computation ...
1499 getAmode :: StixExpr -> NatM Amode
1501 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1503 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1505 #if alpha_TARGET_ARCH
1507 getAmode (StPrim IntSubOp [x, StInt i])
1508 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1509 getRegister x `thenNat` \ register ->
1511 code = registerCode register tmp
1512 reg = registerName register tmp
1513 off = ImmInt (-(fromInteger i))
1515 returnNat (Amode (AddrRegImm reg off) code)
1517 getAmode (StPrim IntAddOp [x, StInt i])
1518 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1519 getRegister x `thenNat` \ register ->
1521 code = registerCode register tmp
1522 reg = registerName register tmp
1523 off = ImmInt (fromInteger i)
1525 returnNat (Amode (AddrRegImm reg off) code)
1529 = returnNat (Amode (AddrImm imm__2) id)
1532 imm__2 = case imm of Just x -> x
1535 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1536 getRegister other `thenNat` \ register ->
1538 code = registerCode register tmp
1539 reg = registerName register tmp
1541 returnNat (Amode (AddrReg reg) code)
1543 #endif {- alpha_TARGET_ARCH -}
1545 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1547 #if i386_TARGET_ARCH
1549 -- This is all just ridiculous, since it carefully undoes
1550 -- what mangleIndexTree has just done.
1551 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1552 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1553 getRegister x `thenNat` \ register ->
1555 code = registerCode register tmp
1556 reg = registerName register tmp
1557 off = ImmInt (-(fromInteger i))
1559 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1561 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1563 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1566 imm__2 = case imm of Just x -> x
1568 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1569 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1570 getRegister x `thenNat` \ register ->
1572 code = registerCode register tmp
1573 reg = registerName register tmp
1574 off = ImmInt (fromInteger i)
1576 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1578 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1579 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1580 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1581 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1582 getRegister x `thenNat` \ register1 ->
1583 getRegister y `thenNat` \ register2 ->
1585 code1 = registerCode register1 tmp1
1586 reg1 = registerName register1 tmp1
1587 code2 = registerCode register2 tmp2
1588 reg2 = registerName register2 tmp2
1589 code__2 = code1 `appOL` code2
1590 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1592 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1597 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1600 imm__2 = case imm of Just x -> x
1603 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1604 getRegister other `thenNat` \ register ->
1606 code = registerCode register tmp
1607 reg = registerName register tmp
1609 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1611 #endif {- i386_TARGET_ARCH -}
1613 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1615 #if sparc_TARGET_ARCH
1617 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1619 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1620 getRegister x `thenNat` \ register ->
1622 code = registerCode register tmp
1623 reg = registerName register tmp
1624 off = ImmInt (-(fromInteger i))
1626 returnNat (Amode (AddrRegImm reg off) code)
1629 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1631 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1632 getRegister x `thenNat` \ register ->
1634 code = registerCode register tmp
1635 reg = registerName register tmp
1636 off = ImmInt (fromInteger i)
1638 returnNat (Amode (AddrRegImm reg off) code)
1640 getAmode (StMachOp MO_Nat_Add [x, y])
1641 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1642 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1643 getRegister x `thenNat` \ register1 ->
1644 getRegister y `thenNat` \ register2 ->
1646 code1 = registerCode register1 tmp1
1647 reg1 = registerName register1 tmp1
1648 code2 = registerCode register2 tmp2
1649 reg2 = registerName register2 tmp2
1650 code__2 = code1 `appOL` code2
1652 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1656 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1658 code = unitOL (SETHI (HI imm__2) tmp)
1660 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1663 imm__2 = case imm of Just x -> x
1666 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1667 getRegister other `thenNat` \ register ->
1669 code = registerCode register tmp
1670 reg = registerName register tmp
1673 returnNat (Amode (AddrRegImm reg off) code)
1675 #endif {- sparc_TARGET_ARCH -}
1677 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1680 %************************************************************************
1682 \subsection{The @CondCode@ type}
1684 %************************************************************************
1686 Condition codes passed up the tree.
1688 data CondCode = CondCode Bool Cond InstrBlock
1690 condName (CondCode _ cond _) = cond
1691 condFloat (CondCode is_float _ _) = is_float
1692 condCode (CondCode _ _ code) = code
1695 Set up a condition code for a conditional branch.
1698 getCondCode :: StixExpr -> NatM CondCode
1700 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1702 #if alpha_TARGET_ARCH
1703 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1704 #endif {- alpha_TARGET_ARCH -}
1706 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1708 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1709 -- yes, they really do seem to want exactly the same!
1711 getCondCode (StMachOp mop [x, y])
1713 MO_32U_Gt -> condIntCode GTT x y
1714 MO_32U_Ge -> condIntCode GE x y
1715 MO_32U_Eq -> condIntCode EQQ x y
1716 MO_32U_Ne -> condIntCode NE x y
1717 MO_32U_Lt -> condIntCode LTT x y
1718 MO_32U_Le -> condIntCode LE x y
1720 MO_Nat_Eq -> condIntCode EQQ x y
1721 MO_Nat_Ne -> condIntCode NE x y
1723 MO_NatS_Gt -> condIntCode GTT x y
1724 MO_NatS_Ge -> condIntCode GE x y
1725 MO_NatS_Lt -> condIntCode LTT x y
1726 MO_NatS_Le -> condIntCode LE x y
1728 MO_NatU_Gt -> condIntCode GU x y
1729 MO_NatU_Ge -> condIntCode GEU x y
1730 MO_NatU_Lt -> condIntCode LU x y
1731 MO_NatU_Le -> condIntCode LEU x y
1733 MO_Flt_Gt -> condFltCode GTT x y
1734 MO_Flt_Ge -> condFltCode GE x y
1735 MO_Flt_Eq -> condFltCode EQQ x y
1736 MO_Flt_Ne -> condFltCode NE x y
1737 MO_Flt_Lt -> condFltCode LTT x y
1738 MO_Flt_Le -> condFltCode LE x y
1740 MO_Dbl_Gt -> condFltCode GTT x y
1741 MO_Dbl_Ge -> condFltCode GE x y
1742 MO_Dbl_Eq -> condFltCode EQQ x y
1743 MO_Dbl_Ne -> condFltCode NE x y
1744 MO_Dbl_Lt -> condFltCode LTT x y
1745 MO_Dbl_Le -> condFltCode LE x y
1747 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1749 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1751 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1753 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1758 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1759 passed back up the tree.
1762 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1764 #if alpha_TARGET_ARCH
1765 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1766 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1767 #endif {- alpha_TARGET_ARCH -}
1769 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1770 #if i386_TARGET_ARCH
1772 -- memory vs immediate
1773 condIntCode cond (StInd pk x) y
1774 | Just i <- maybeImm y
1775 = getAmode x `thenNat` \ amode ->
1777 code1 = amodeCode amode
1778 x__2 = amodeAddr amode
1779 sz = primRepToSize pk
1780 code__2 = code1 `snocOL`
1781 CMP sz (OpImm i) (OpAddr x__2)
1783 returnNat (CondCode False cond code__2)
1786 condIntCode cond x (StInt 0)
1787 = getRegister x `thenNat` \ register1 ->
1788 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1790 code1 = registerCode register1 tmp1
1791 src1 = registerName register1 tmp1
1792 code__2 = code1 `snocOL`
1793 TEST L (OpReg src1) (OpReg src1)
1795 returnNat (CondCode False cond code__2)
1797 -- anything vs immediate
1798 condIntCode cond x y
1799 | Just i <- maybeImm y
1800 = getRegister x `thenNat` \ register1 ->
1801 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1803 code1 = registerCode register1 tmp1
1804 src1 = registerName register1 tmp1
1805 code__2 = code1 `snocOL`
1806 CMP L (OpImm i) (OpReg src1)
1808 returnNat (CondCode False cond code__2)
1810 -- memory vs anything
1811 condIntCode cond (StInd pk x) y
1812 = getAmode x `thenNat` \ amode_x ->
1813 getRegister y `thenNat` \ reg_y ->
1814 getNewRegNCG IntRep `thenNat` \ tmp ->
1816 c_x = amodeCode amode_x
1817 am_x = amodeAddr amode_x
1818 c_y = registerCode reg_y tmp
1819 r_y = registerName reg_y tmp
1820 sz = primRepToSize pk
1822 -- optimisation: if there's no code for x, just an amode,
1823 -- use whatever reg y winds up in. Assumes that c_y doesn't
1824 -- clobber any regs in the amode am_x, which I'm not sure is
1825 -- justified. The otherwise clause makes the same assumption.
1826 code__2 | isNilOL c_x
1828 CMP sz (OpReg r_y) (OpAddr am_x)
1832 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1834 CMP sz (OpReg tmp) (OpAddr am_x)
1836 returnNat (CondCode False cond code__2)
1838 -- anything vs memory
1840 condIntCode cond y (StInd pk x)
1841 = getAmode x `thenNat` \ amode_x ->
1842 getRegister y `thenNat` \ reg_y ->
1843 getNewRegNCG IntRep `thenNat` \ tmp ->
1845 c_x = amodeCode amode_x
1846 am_x = amodeAddr amode_x
1847 c_y = registerCode reg_y tmp
1848 r_y = registerName reg_y tmp
1849 sz = primRepToSize pk
1850 -- same optimisation and nagging doubts as previous clause
1851 code__2 | isNilOL c_x
1853 CMP sz (OpAddr am_x) (OpReg r_y)
1857 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1859 CMP sz (OpAddr am_x) (OpReg tmp)
1861 returnNat (CondCode False cond code__2)
1863 -- anything vs anything
1864 condIntCode cond x y
1865 = getRegister x `thenNat` \ register1 ->
1866 getRegister y `thenNat` \ register2 ->
1867 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1868 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1870 code1 = registerCode register1 tmp1
1871 src1 = registerName register1 tmp1
1872 code2 = registerCode register2 tmp2
1873 src2 = registerName register2 tmp2
1874 code__2 = code1 `snocOL`
1875 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1877 CMP L (OpReg src2) (OpReg tmp1)
1879 returnNat (CondCode False cond code__2)
1882 condFltCode cond x y
1883 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1884 getRegister x `thenNat` \ register1 ->
1885 getRegister y `thenNat` \ register2 ->
1886 getNewRegNCG (registerRep register1)
1888 getNewRegNCG (registerRep register2)
1890 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1892 code1 = registerCode register1 tmp1
1893 src1 = registerName register1 tmp1
1895 code2 = registerCode register2 tmp2
1896 src2 = registerName register2 tmp2
1898 code__2 | isAny register1
1899 = code1 `appOL` -- result in tmp1
1905 GMOV src1 tmp1 `appOL`
1909 -- The GCMP insn does the test and sets the zero flag if comparable
1910 -- and true. Hence we always supply EQQ as the condition to test.
1911 returnNat (CondCode True EQQ code__2)
1913 #endif {- i386_TARGET_ARCH -}
1915 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1917 #if sparc_TARGET_ARCH
1919 condIntCode cond x (StInt y)
1921 = getRegister x `thenNat` \ register ->
1922 getNewRegNCG IntRep `thenNat` \ tmp ->
1924 code = registerCode register tmp
1925 src1 = registerName register tmp
1926 src2 = ImmInt (fromInteger y)
1927 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1929 returnNat (CondCode False cond code__2)
1931 condIntCode cond x y
1932 = getRegister x `thenNat` \ register1 ->
1933 getRegister y `thenNat` \ register2 ->
1934 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1935 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1937 code1 = registerCode register1 tmp1
1938 src1 = registerName register1 tmp1
1939 code2 = registerCode register2 tmp2
1940 src2 = registerName register2 tmp2
1941 code__2 = code1 `appOL` code2 `snocOL`
1942 SUB False True src1 (RIReg src2) g0
1944 returnNat (CondCode False cond code__2)
1947 condFltCode cond x y
1948 = getRegister x `thenNat` \ register1 ->
1949 getRegister y `thenNat` \ register2 ->
1950 getNewRegNCG (registerRep register1)
1952 getNewRegNCG (registerRep register2)
1954 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1956 promote x = FxTOy F DF x tmp
1958 pk1 = registerRep register1
1959 code1 = registerCode register1 tmp1
1960 src1 = registerName register1 tmp1
1962 pk2 = registerRep register2
1963 code2 = registerCode register2 tmp2
1964 src2 = registerName register2 tmp2
1968 code1 `appOL` code2 `snocOL`
1969 FCMP True (primRepToSize pk1) src1 src2
1970 else if pk1 == FloatRep then
1971 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1972 FCMP True DF tmp src2
1974 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1975 FCMP True DF src1 tmp
1977 returnNat (CondCode True cond code__2)
1979 #endif {- sparc_TARGET_ARCH -}
1981 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1984 %************************************************************************
1986 \subsection{Generating assignments}
1988 %************************************************************************
1990 Assignments are really at the heart of the whole code generation
1991 business. Almost all top-level nodes of any real importance are
1992 assignments, which correspond to loads, stores, or register transfers.
1993 If we're really lucky, some of the register transfers will go away,
1994 because we can use the destination register to complete the code
1995 generation for the right hand side. This only fails when the right
1996 hand side is forced into a fixed register (e.g. the result of a call).
1999 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2000 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2002 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2003 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2005 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2007 #if alpha_TARGET_ARCH
2009 assignIntCode pk (StInd _ dst) src
2010 = getNewRegNCG IntRep `thenNat` \ tmp ->
2011 getAmode dst `thenNat` \ amode ->
2012 getRegister src `thenNat` \ register ->
2014 code1 = amodeCode amode []
2015 dst__2 = amodeAddr amode
2016 code2 = registerCode register tmp []
2017 src__2 = registerName register tmp
2018 sz = primRepToSize pk
2019 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2023 assignIntCode pk dst src
2024 = getRegister dst `thenNat` \ register1 ->
2025 getRegister src `thenNat` \ register2 ->
2027 dst__2 = registerName register1 zeroh
2028 code = registerCode register2 dst__2
2029 src__2 = registerName register2 dst__2
2030 code__2 = if isFixed register2
2031 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2036 #endif {- alpha_TARGET_ARCH -}
2038 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2040 #if i386_TARGET_ARCH
2042 -- non-FP assignment to memory
2043 assignMem_IntCode pk addr src
2044 = getAmode addr `thenNat` \ amode ->
2045 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2046 getNewRegNCG PtrRep `thenNat` \ tmp ->
2048 -- In general, if the address computation for dst may require
2049 -- some insns preceding the addressing mode itself. So there's
2050 -- no guarantee that the code for dst and the code for src won't
2051 -- write the same register. This means either the address or
2052 -- the value needs to be copied into a temporary. We detect the
2053 -- common case where the amode has no code, and elide the copy.
2054 codea = amodeCode amode
2055 dst__a = amodeAddr amode
2057 code | isNilOL codea
2059 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2062 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2064 MOV (primRepToSize pk) opsrc
2065 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2071 -> NatM (InstrBlock,Operand) -- code, operator
2074 | Just x <- maybeImm op
2075 = returnNat (nilOL, OpImm x)
2078 = getRegister op `thenNat` \ register ->
2079 getNewRegNCG (registerRep register)
2081 let code = registerCode register tmp
2082 reg = registerName register tmp
2084 returnNat (code, OpReg reg)
2086 -- Assign; dst is a reg, rhs is mem
2087 assignReg_IntCode pk reg (StInd pks src)
2088 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2089 getAmode src `thenNat` \ amode ->
2090 getRegisterReg reg `thenNat` \ reg_dst ->
2092 c_addr = amodeCode amode
2093 am_addr = amodeAddr amode
2094 r_dst = registerName reg_dst tmp
2095 szs = primRepToSize pks
2104 code = c_addr `snocOL`
2105 opc (OpAddr am_addr) (OpReg r_dst)
2109 -- dst is a reg, but src could be anything
2110 assignReg_IntCode pk reg src
2111 = getRegisterReg reg `thenNat` \ registerd ->
2112 getRegister src `thenNat` \ registers ->
2113 getNewRegNCG IntRep `thenNat` \ tmp ->
2115 r_dst = registerName registerd tmp
2116 r_src = registerName registers r_dst
2117 c_src = registerCode registers r_dst
2119 code = c_src `snocOL`
2120 MOV L (OpReg r_src) (OpReg r_dst)
2124 #endif {- i386_TARGET_ARCH -}
2126 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2128 #if sparc_TARGET_ARCH
2130 assignMem_IntCode pk addr src
2131 = getNewRegNCG IntRep `thenNat` \ tmp ->
2132 getAmode addr `thenNat` \ amode ->
2133 getRegister src `thenNat` \ register ->
2135 code1 = amodeCode amode
2136 dst__2 = amodeAddr amode
2137 code2 = registerCode register tmp
2138 src__2 = registerName register tmp
2139 sz = primRepToSize pk
2140 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2144 assignReg_IntCode pk reg src
2145 = getRegister src `thenNat` \ register2 ->
2146 getRegisterReg reg `thenNat` \ register1 ->
2148 dst__2 = registerName register1 g0
2149 code = registerCode register2 dst__2
2150 src__2 = registerName register2 dst__2
2151 code__2 = if isFixed register2
2152 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2157 #endif {- sparc_TARGET_ARCH -}
2159 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2162 % --------------------------------
2163 Floating-point assignments:
2164 % --------------------------------
2167 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2168 #if alpha_TARGET_ARCH
2170 assignFltCode pk (StInd _ dst) src
2171 = getNewRegNCG pk `thenNat` \ tmp ->
2172 getAmode dst `thenNat` \ amode ->
2173 getRegister src `thenNat` \ register ->
2175 code1 = amodeCode amode []
2176 dst__2 = amodeAddr amode
2177 code2 = registerCode register tmp []
2178 src__2 = registerName register tmp
2179 sz = primRepToSize pk
2180 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2184 assignFltCode pk dst src
2185 = getRegister dst `thenNat` \ register1 ->
2186 getRegister src `thenNat` \ register2 ->
2188 dst__2 = registerName register1 zeroh
2189 code = registerCode register2 dst__2
2190 src__2 = registerName register2 dst__2
2191 code__2 = if isFixed register2
2192 then code . mkSeqInstr (FMOV src__2 dst__2)
2197 #endif {- alpha_TARGET_ARCH -}
2199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2201 #if i386_TARGET_ARCH
2203 -- Floating point assignment to memory
2204 assignMem_FltCode pk addr src
2205 = getRegister src `thenNat` \ reg_src ->
2206 getRegister addr `thenNat` \ reg_addr ->
2207 getNewRegNCG pk `thenNat` \ tmp_src ->
2208 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2209 let r_src = registerName reg_src tmp_src
2210 c_src = registerCode reg_src tmp_src
2211 r_addr = registerName reg_addr tmp_addr
2212 c_addr = registerCode reg_addr tmp_addr
2213 sz = primRepToSize pk
2215 code = c_src `appOL`
2216 -- no need to preserve r_src across the addr computation,
2217 -- since r_src must be a float reg
2218 -- whilst r_addr is an int reg
2221 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2225 -- Floating point assignment to a register/temporary
2226 assignReg_FltCode pk reg src
2227 = getRegisterReg reg `thenNat` \ reg_dst ->
2228 getRegister src `thenNat` \ reg_src ->
2229 getNewRegNCG pk `thenNat` \ tmp ->
2231 r_dst = registerName reg_dst tmp
2232 r_src = registerName reg_src r_dst
2233 c_src = registerCode reg_src r_dst
2235 code = if isFixed reg_src
2236 then c_src `snocOL` GMOV r_src r_dst
2242 #endif {- i386_TARGET_ARCH -}
2244 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2246 #if sparc_TARGET_ARCH
2248 -- Floating point assignment to memory
2249 assignMem_FltCode pk addr src
2250 = getNewRegNCG pk `thenNat` \ tmp1 ->
2251 getAmode addr `thenNat` \ amode ->
2252 getRegister src `thenNat` \ register ->
2254 sz = primRepToSize pk
2255 dst__2 = amodeAddr amode
2257 code1 = amodeCode amode
2258 code2 = registerCode register tmp1
2260 src__2 = registerName register tmp1
2261 pk__2 = registerRep register
2262 sz__2 = primRepToSize pk__2
2264 code__2 = code1 `appOL` code2 `appOL`
2266 then unitOL (ST sz src__2 dst__2)
2267 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2271 -- Floating point assignment to a register/temporary
2272 -- Why is this so bizarrely ugly?
2273 assignReg_FltCode pk reg src
2274 = getRegisterReg reg `thenNat` \ register1 ->
2275 getRegister src `thenNat` \ register2 ->
2277 pk__2 = registerRep register2
2278 sz__2 = primRepToSize pk__2
2280 getNewRegNCG pk__2 `thenNat` \ tmp ->
2282 sz = primRepToSize pk
2283 dst__2 = registerName register1 g0 -- must be Fixed
2284 reg__2 = if pk /= pk__2 then tmp else dst__2
2285 code = registerCode register2 reg__2
2286 src__2 = registerName register2 reg__2
2289 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2290 else if isFixed register2 then
2291 code `snocOL` FMOV sz src__2 dst__2
2297 #endif {- sparc_TARGET_ARCH -}
2299 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2302 %************************************************************************
2304 \subsection{Generating an unconditional branch}
2306 %************************************************************************
2308 We accept two types of targets: an immediate CLabel or a tree that
2309 gets evaluated into a register. Any CLabels which are AsmTemporaries
2310 are assumed to be in the local block of code, close enough for a
2311 branch instruction. Other CLabels are assumed to be far away.
2313 (If applicable) Do not fill the delay slots here; you will confuse the
2317 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2319 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2321 #if alpha_TARGET_ARCH
2323 genJump (StCLbl lbl)
2324 | isAsmTemp lbl = returnInstr (BR target)
2325 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2327 target = ImmCLbl lbl
2330 = getRegister tree `thenNat` \ register ->
2331 getNewRegNCG PtrRep `thenNat` \ tmp ->
2333 dst = registerName register pv
2334 code = registerCode register pv
2335 target = registerName register pv
2337 if isFixed register then
2338 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2340 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2342 #endif {- alpha_TARGET_ARCH -}
2344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2346 #if i386_TARGET_ARCH
2348 genJump dsts (StInd pk mem)
2349 = getAmode mem `thenNat` \ amode ->
2351 code = amodeCode amode
2352 target = amodeAddr amode
2354 returnNat (code `snocOL` JMP dsts (OpAddr target))
2358 = returnNat (unitOL (JMP dsts (OpImm target)))
2361 = getRegister tree `thenNat` \ register ->
2362 getNewRegNCG PtrRep `thenNat` \ tmp ->
2364 code = registerCode register tmp
2365 target = registerName register tmp
2367 returnNat (code `snocOL` JMP dsts (OpReg target))
2370 target = case imm of Just x -> x
2372 #endif {- i386_TARGET_ARCH -}
2374 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2376 #if sparc_TARGET_ARCH
2378 genJump dsts (StCLbl lbl)
2379 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2380 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2381 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2383 target = ImmCLbl lbl
2386 = getRegister tree `thenNat` \ register ->
2387 getNewRegNCG PtrRep `thenNat` \ tmp ->
2389 code = registerCode register tmp
2390 target = registerName register tmp
2392 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2394 #endif {- sparc_TARGET_ARCH -}
2396 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2399 %************************************************************************
2401 \subsection{Conditional jumps}
2403 %************************************************************************
2405 Conditional jumps are always to local labels, so we can use branch
2406 instructions. We peek at the arguments to decide what kind of
2409 ALPHA: For comparisons with 0, we're laughing, because we can just do
2410 the desired conditional branch.
2412 I386: First, we have to ensure that the condition
2413 codes are set according to the supplied comparison operation.
2415 SPARC: First, we have to ensure that the condition codes are set
2416 according to the supplied comparison operation. We generate slightly
2417 different code for floating point comparisons, because a floating
2418 point operation cannot directly precede a @BF@. We assume the worst
2419 and fill that slot with a @NOP@.
2421 SPARC: Do not fill the delay slots here; you will confuse the register
2426 :: CLabel -- the branch target
2427 -> StixExpr -- the condition on which to branch
2430 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2432 #if alpha_TARGET_ARCH
2434 genCondJump lbl (StPrim op [x, StInt 0])
2435 = getRegister x `thenNat` \ register ->
2436 getNewRegNCG (registerRep register)
2439 code = registerCode register tmp
2440 value = registerName register tmp
2441 pk = registerRep register
2442 target = ImmCLbl lbl
2444 returnSeq code [BI (cmpOp op) value target]
2446 cmpOp CharGtOp = GTT
2448 cmpOp CharEqOp = EQQ
2450 cmpOp CharLtOp = LTT
2459 cmpOp WordGeOp = ALWAYS
2460 cmpOp WordEqOp = EQQ
2462 cmpOp WordLtOp = NEVER
2463 cmpOp WordLeOp = EQQ
2465 cmpOp AddrGeOp = ALWAYS
2466 cmpOp AddrEqOp = EQQ
2468 cmpOp AddrLtOp = NEVER
2469 cmpOp AddrLeOp = EQQ
2471 genCondJump lbl (StPrim op [x, StDouble 0.0])
2472 = getRegister x `thenNat` \ register ->
2473 getNewRegNCG (registerRep register)
2476 code = registerCode register tmp
2477 value = registerName register tmp
2478 pk = registerRep register
2479 target = ImmCLbl lbl
2481 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2483 cmpOp FloatGtOp = GTT
2484 cmpOp FloatGeOp = GE
2485 cmpOp FloatEqOp = EQQ
2486 cmpOp FloatNeOp = NE
2487 cmpOp FloatLtOp = LTT
2488 cmpOp FloatLeOp = LE
2489 cmpOp DoubleGtOp = GTT
2490 cmpOp DoubleGeOp = GE
2491 cmpOp DoubleEqOp = EQQ
2492 cmpOp DoubleNeOp = NE
2493 cmpOp DoubleLtOp = LTT
2494 cmpOp DoubleLeOp = LE
2496 genCondJump lbl (StPrim op [x, y])
2498 = trivialFCode pr instr x y `thenNat` \ register ->
2499 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2501 code = registerCode register tmp
2502 result = registerName register tmp
2503 target = ImmCLbl lbl
2505 returnNat (code . mkSeqInstr (BF cond result target))
2507 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2509 fltCmpOp op = case op of
2523 (instr, cond) = case op of
2524 FloatGtOp -> (FCMP TF LE, EQQ)
2525 FloatGeOp -> (FCMP TF LTT, EQQ)
2526 FloatEqOp -> (FCMP TF EQQ, NE)
2527 FloatNeOp -> (FCMP TF EQQ, EQQ)
2528 FloatLtOp -> (FCMP TF LTT, NE)
2529 FloatLeOp -> (FCMP TF LE, NE)
2530 DoubleGtOp -> (FCMP TF LE, EQQ)
2531 DoubleGeOp -> (FCMP TF LTT, EQQ)
2532 DoubleEqOp -> (FCMP TF EQQ, NE)
2533 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2534 DoubleLtOp -> (FCMP TF LTT, NE)
2535 DoubleLeOp -> (FCMP TF LE, NE)
2537 genCondJump lbl (StPrim op [x, y])
2538 = trivialCode instr x y `thenNat` \ register ->
2539 getNewRegNCG IntRep `thenNat` \ tmp ->
2541 code = registerCode register tmp
2542 result = registerName register tmp
2543 target = ImmCLbl lbl
2545 returnNat (code . mkSeqInstr (BI cond result target))
2547 (instr, cond) = case op of
2548 CharGtOp -> (CMP LE, EQQ)
2549 CharGeOp -> (CMP LTT, EQQ)
2550 CharEqOp -> (CMP EQQ, NE)
2551 CharNeOp -> (CMP EQQ, EQQ)
2552 CharLtOp -> (CMP LTT, NE)
2553 CharLeOp -> (CMP LE, NE)
2554 IntGtOp -> (CMP LE, EQQ)
2555 IntGeOp -> (CMP LTT, EQQ)
2556 IntEqOp -> (CMP EQQ, NE)
2557 IntNeOp -> (CMP EQQ, EQQ)
2558 IntLtOp -> (CMP LTT, NE)
2559 IntLeOp -> (CMP LE, NE)
2560 WordGtOp -> (CMP ULE, EQQ)
2561 WordGeOp -> (CMP ULT, EQQ)
2562 WordEqOp -> (CMP EQQ, NE)
2563 WordNeOp -> (CMP EQQ, EQQ)
2564 WordLtOp -> (CMP ULT, NE)
2565 WordLeOp -> (CMP ULE, NE)
2566 AddrGtOp -> (CMP ULE, EQQ)
2567 AddrGeOp -> (CMP ULT, EQQ)
2568 AddrEqOp -> (CMP EQQ, NE)
2569 AddrNeOp -> (CMP EQQ, EQQ)
2570 AddrLtOp -> (CMP ULT, NE)
2571 AddrLeOp -> (CMP ULE, NE)
2573 #endif {- alpha_TARGET_ARCH -}
2575 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2577 #if i386_TARGET_ARCH
2579 genCondJump lbl bool
2580 = getCondCode bool `thenNat` \ condition ->
2582 code = condCode condition
2583 cond = condName condition
2585 returnNat (code `snocOL` JXX cond lbl)
2587 #endif {- i386_TARGET_ARCH -}
2589 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2591 #if sparc_TARGET_ARCH
2593 genCondJump lbl bool
2594 = getCondCode bool `thenNat` \ condition ->
2596 code = condCode condition
2597 cond = condName condition
2598 target = ImmCLbl lbl
2603 if condFloat condition
2604 then [NOP, BF cond False target, NOP]
2605 else [BI cond False target, NOP]
2609 #endif {- sparc_TARGET_ARCH -}
2611 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2614 %************************************************************************
2616 \subsection{Generating C calls}
2618 %************************************************************************
2620 Now the biggest nightmare---calls. Most of the nastiness is buried in
2621 @get_arg@, which moves the arguments to the correct registers/stack
2622 locations. Apart from that, the code is easy.
2624 (If applicable) Do not fill the delay slots here; you will confuse the
2629 :: (Either FastString StixExpr) -- function to call
2631 -> PrimRep -- type of the result
2632 -> [StixExpr] -- arguments (of mixed type)
2635 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2637 #if alpha_TARGET_ARCH
2639 genCCall fn cconv kind args
2640 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2641 `thenNat` \ ((unused,_), argCode) ->
2643 nRegs = length allArgRegs - length unused
2644 code = asmSeqThen (map ($ []) argCode)
2647 LDA pv (AddrImm (ImmLab (ptext fn))),
2648 JSR ra (AddrReg pv) nRegs,
2649 LDGP gp (AddrReg ra)]
2651 ------------------------
2652 {- Try to get a value into a specific register (or registers) for
2653 a call. The first 6 arguments go into the appropriate
2654 argument register (separate registers for integer and floating
2655 point arguments, but used in lock-step), and the remaining
2656 arguments are dumped to the stack, beginning at 0(sp). Our
2657 first argument is a pair of the list of remaining argument
2658 registers to be assigned for this call and the next stack
2659 offset to use for overflowing arguments. This way,
2660 @get_Arg@ can be applied to all of a call's arguments using
2664 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2665 -> StixTree -- Current argument
2666 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2668 -- We have to use up all of our argument registers first...
2670 get_arg ((iDst,fDst):dsts, offset) arg
2671 = getRegister arg `thenNat` \ register ->
2673 reg = if isFloatingRep pk then fDst else iDst
2674 code = registerCode register reg
2675 src = registerName register reg
2676 pk = registerRep register
2679 if isFloatingRep pk then
2680 ((dsts, offset), if isFixed register then
2681 code . mkSeqInstr (FMOV src fDst)
2684 ((dsts, offset), if isFixed register then
2685 code . mkSeqInstr (OR src (RIReg src) iDst)
2688 -- Once we have run out of argument registers, we move to the
2691 get_arg ([], offset) arg
2692 = getRegister arg `thenNat` \ register ->
2693 getNewRegNCG (registerRep register)
2696 code = registerCode register tmp
2697 src = registerName register tmp
2698 pk = registerRep register
2699 sz = primRepToSize pk
2701 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2703 #endif {- alpha_TARGET_ARCH -}
2705 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2707 #if i386_TARGET_ARCH
2709 genCCall fn cconv ret_rep args
2711 (reverse args) `thenNat` \ sizes_n_codes ->
2712 getDeltaNat `thenNat` \ delta ->
2713 let (sizes, push_codes) = unzip sizes_n_codes
2714 tot_arg_size = sum sizes
2716 -- deal with static vs dynamic call targets
2719 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2721 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2722 ASSERT(case dyn_rep of { L -> True; _ -> False})
2723 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2725 `thenNat` \ callinsns ->
2726 let push_code = concatOL push_codes
2727 call = callinsns `appOL`
2729 -- Deallocate parameters after call for ccall;
2730 -- but not for stdcall (callee does it)
2731 (if cconv == StdCallConv then [] else
2732 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2734 [DELTA (delta + tot_arg_size)]
2737 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2738 returnNat (push_code `appOL` call)
2741 -- function names that begin with '.' are assumed to be special
2742 -- internally generated names like '.mul,' which don't get an
2743 -- underscore prefix
2744 -- ToDo:needed (WDP 96/03) ???
2745 fn_u = unpackFS (unLeft fn)
2748 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2749 | otherwise -- General case
2750 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2752 stdcallsize tot_arg_size
2753 | cconv == StdCallConv = '@':show tot_arg_size
2761 push_arg :: StixExpr{-current argument-}
2762 -> NatM (Int, InstrBlock) -- argsz, code
2765 | is64BitRep arg_rep
2766 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2767 getDeltaNat `thenNat` \ delta ->
2768 setDeltaNat (delta - 8) `thenNat` \ _ ->
2769 let r_lo = VirtualRegI vr_lo
2770 r_hi = getHiVRegFromLo r_lo
2773 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2774 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2777 = get_op arg `thenNat` \ (code, reg, sz) ->
2778 getDeltaNat `thenNat` \ delta ->
2779 arg_size sz `bind` \ size ->
2780 setDeltaNat (delta-size) `thenNat` \ _ ->
2781 if (case sz of DF -> True; F -> True; _ -> False)
2782 then returnNat (size,
2784 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2786 GST sz reg (AddrBaseIndex (Just esp)
2790 else returnNat (size,
2792 PUSH L (OpReg reg) `snocOL`
2796 arg_rep = repOfStixExpr arg
2801 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2804 = getRegister op `thenNat` \ register ->
2805 getNewRegNCG (registerRep register)
2808 code = registerCode register tmp
2809 reg = registerName register tmp
2810 pk = registerRep register
2811 sz = primRepToSize pk
2813 returnNat (code, reg, sz)
2815 #endif {- i386_TARGET_ARCH -}
2817 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2819 #if sparc_TARGET_ARCH
2821 The SPARC calling convention is an absolute
2822 nightmare. The first 6x32 bits of arguments are mapped into
2823 %o0 through %o5, and the remaining arguments are dumped to the
2824 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2826 If we have to put args on the stack, move %o6==%sp down by
2827 the number of words to go on the stack, to ensure there's enough space.
2829 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2830 16 words above the stack pointer is a word for the address of
2831 a structure return value. I use this as a temporary location
2832 for moving values from float to int regs. Certainly it isn't
2833 safe to put anything in the 16 words starting at %sp, since
2834 this area can get trashed at any time due to window overflows
2835 caused by signal handlers.
2837 A final complication (if the above isn't enough) is that
2838 we can't blithely calculate the arguments one by one into
2839 %o0 .. %o5. Consider the following nested calls:
2843 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2844 the inner call will itself use %o0, which trashes the value put there
2845 in preparation for the outer call. Upshot: we need to calculate the
2846 args into temporary regs, and move those to arg regs or onto the
2847 stack only immediately prior to the call proper. Sigh.
2850 genCCall fn cconv kind args
2851 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2853 (argcodes, vregss) = unzip argcode_and_vregs
2854 n_argRegs = length allArgRegs
2855 n_argRegs_used = min (length vregs) n_argRegs
2856 vregs = concat vregss
2858 -- deal with static vs dynamic call targets
2861 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2863 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2864 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2866 `thenNat` \ callinsns ->
2868 argcode = concatOL argcodes
2869 (move_sp_down, move_sp_up)
2870 = let nn = length vregs - n_argRegs
2871 + 1 -- (for the road)
2874 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2876 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2878 returnNat (argcode `appOL`
2879 move_sp_down `appOL`
2880 transfer_code `appOL`
2885 -- function names that begin with '.' are assumed to be special
2886 -- internally generated names like '.mul,' which don't get an
2887 -- underscore prefix
2888 -- ToDo:needed (WDP 96/03) ???
2889 fn_static = unLeft fn
2890 fn__2 = case (headFS fn_static) of
2891 '.' -> ImmLit (ptext fn_static)
2892 _ -> ImmLab False (ptext fn_static)
2894 -- move args from the integer vregs into which they have been
2895 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2896 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2898 move_final [] _ offset -- all args done
2901 move_final (v:vs) [] offset -- out of aregs; move to stack
2902 = ST W v (spRel offset)
2903 : move_final vs [] (offset+1)
2905 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2906 = OR False g0 (RIReg v) a
2907 : move_final vs az offset
2909 -- generate code to calculate an argument, and move it into one
2910 -- or two integer vregs.
2911 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2912 arg_to_int_vregs arg
2913 | is64BitRep (repOfStixExpr arg)
2914 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2915 let r_lo = VirtualRegI vr_lo
2916 r_hi = getHiVRegFromLo r_lo
2917 in returnNat (code, [r_hi, r_lo])
2919 = getRegister arg `thenNat` \ register ->
2920 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2921 let code = registerCode register tmp
2922 src = registerName register tmp
2923 pk = registerRep register
2925 -- the value is in src. Get it into 1 or 2 int vregs.
2928 getNewRegNCG WordRep `thenNat` \ v1 ->
2929 getNewRegNCG WordRep `thenNat` \ v2 ->
2932 FMOV DF src f0 `snocOL`
2933 ST F f0 (spRel 16) `snocOL`
2934 LD W (spRel 16) v1 `snocOL`
2935 ST F (fPair f0) (spRel 16) `snocOL`
2941 getNewRegNCG WordRep `thenNat` \ v1 ->
2944 ST F src (spRel 16) `snocOL`
2950 getNewRegNCG WordRep `thenNat` \ v1 ->
2952 code `snocOL` OR False g0 (RIReg src) v1
2956 #endif {- sparc_TARGET_ARCH -}
2958 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2961 %************************************************************************
2963 \subsection{Support bits}
2965 %************************************************************************
2967 %************************************************************************
2969 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2971 %************************************************************************
2973 Turn those condition codes into integers now (when they appear on
2974 the right hand side of an assignment).
2976 (If applicable) Do not fill the delay slots here; you will confuse the
2980 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2982 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2984 #if alpha_TARGET_ARCH
2985 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2986 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2987 #endif {- alpha_TARGET_ARCH -}
2989 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2991 #if i386_TARGET_ARCH
2994 = condIntCode cond x y `thenNat` \ condition ->
2995 getNewRegNCG IntRep `thenNat` \ tmp ->
2997 code = condCode condition
2998 cond = condName condition
2999 code__2 dst = code `appOL` toOL [
3000 SETCC cond (OpReg tmp),
3001 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3002 MOV L (OpReg tmp) (OpReg dst)]
3004 returnNat (Any IntRep code__2)
3007 = getNatLabelNCG `thenNat` \ lbl1 ->
3008 getNatLabelNCG `thenNat` \ lbl2 ->
3009 condFltCode cond x y `thenNat` \ condition ->
3011 code = condCode condition
3012 cond = condName condition
3013 code__2 dst = code `appOL` toOL [
3015 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3018 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3021 returnNat (Any IntRep code__2)
3023 #endif {- i386_TARGET_ARCH -}
3025 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3027 #if sparc_TARGET_ARCH
3029 condIntReg EQQ x (StInt 0)
3030 = getRegister x `thenNat` \ register ->
3031 getNewRegNCG IntRep `thenNat` \ tmp ->
3033 code = registerCode register tmp
3034 src = registerName register tmp
3035 code__2 dst = code `appOL` toOL [
3036 SUB False True g0 (RIReg src) g0,
3037 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3039 returnNat (Any IntRep code__2)
3042 = getRegister x `thenNat` \ register1 ->
3043 getRegister y `thenNat` \ register2 ->
3044 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3045 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3047 code1 = registerCode register1 tmp1
3048 src1 = registerName register1 tmp1
3049 code2 = registerCode register2 tmp2
3050 src2 = registerName register2 tmp2
3051 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3052 XOR False src1 (RIReg src2) dst,
3053 SUB False True g0 (RIReg dst) g0,
3054 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3056 returnNat (Any IntRep code__2)
3058 condIntReg NE x (StInt 0)
3059 = getRegister x `thenNat` \ register ->
3060 getNewRegNCG IntRep `thenNat` \ tmp ->
3062 code = registerCode register tmp
3063 src = registerName register tmp
3064 code__2 dst = code `appOL` toOL [
3065 SUB False True g0 (RIReg src) g0,
3066 ADD True False g0 (RIImm (ImmInt 0)) dst]
3068 returnNat (Any IntRep code__2)
3071 = getRegister x `thenNat` \ register1 ->
3072 getRegister y `thenNat` \ register2 ->
3073 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3074 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3076 code1 = registerCode register1 tmp1
3077 src1 = registerName register1 tmp1
3078 code2 = registerCode register2 tmp2
3079 src2 = registerName register2 tmp2
3080 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3081 XOR False src1 (RIReg src2) dst,
3082 SUB False True g0 (RIReg dst) g0,
3083 ADD True False g0 (RIImm (ImmInt 0)) dst]
3085 returnNat (Any IntRep code__2)
3088 = getNatLabelNCG `thenNat` \ lbl1 ->
3089 getNatLabelNCG `thenNat` \ lbl2 ->
3090 condIntCode cond x y `thenNat` \ condition ->
3092 code = condCode condition
3093 cond = condName condition
3094 code__2 dst = code `appOL` toOL [
3095 BI cond False (ImmCLbl lbl1), NOP,
3096 OR False g0 (RIImm (ImmInt 0)) dst,
3097 BI ALWAYS False (ImmCLbl lbl2), NOP,
3099 OR False g0 (RIImm (ImmInt 1)) dst,
3102 returnNat (Any IntRep code__2)
3105 = getNatLabelNCG `thenNat` \ lbl1 ->
3106 getNatLabelNCG `thenNat` \ lbl2 ->
3107 condFltCode cond x y `thenNat` \ condition ->
3109 code = condCode condition
3110 cond = condName condition
3111 code__2 dst = code `appOL` toOL [
3113 BF cond False (ImmCLbl lbl1), NOP,
3114 OR False g0 (RIImm (ImmInt 0)) dst,
3115 BI ALWAYS False (ImmCLbl lbl2), NOP,
3117 OR False g0 (RIImm (ImmInt 1)) dst,
3120 returnNat (Any IntRep code__2)
3122 #endif {- sparc_TARGET_ARCH -}
3124 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3127 %************************************************************************
3129 \subsubsection{@trivial*Code@: deal with trivial instructions}
3131 %************************************************************************
3133 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3134 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3135 for constants on the right hand side, because that's where the generic
3136 optimizer will have put them.
3138 Similarly, for unary instructions, we don't have to worry about
3139 matching an StInt as the argument, because genericOpt will already
3140 have handled the constant-folding.
3144 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3145 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3146 -> Maybe (Operand -> Operand -> Instr)
3147 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3149 -> StixExpr -> StixExpr -- the two arguments
3154 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3155 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3156 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3158 -> StixExpr -> StixExpr -- the two arguments
3162 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3163 ,IF_ARCH_i386 ((Operand -> Instr)
3164 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3166 -> StixExpr -- the one argument
3171 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3172 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3173 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3175 -> StixExpr -- the one argument
3178 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3180 #if alpha_TARGET_ARCH
3182 trivialCode instr x (StInt y)
3184 = getRegister x `thenNat` \ register ->
3185 getNewRegNCG IntRep `thenNat` \ tmp ->
3187 code = registerCode register tmp
3188 src1 = registerName register tmp
3189 src2 = ImmInt (fromInteger y)
3190 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3192 returnNat (Any IntRep code__2)
3194 trivialCode instr x y
3195 = getRegister x `thenNat` \ register1 ->
3196 getRegister y `thenNat` \ register2 ->
3197 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3198 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3200 code1 = registerCode register1 tmp1 []
3201 src1 = registerName register1 tmp1
3202 code2 = registerCode register2 tmp2 []
3203 src2 = registerName register2 tmp2
3204 code__2 dst = asmSeqThen [code1, code2] .
3205 mkSeqInstr (instr src1 (RIReg src2) dst)
3207 returnNat (Any IntRep code__2)
3210 trivialUCode instr x
3211 = getRegister x `thenNat` \ register ->
3212 getNewRegNCG IntRep `thenNat` \ tmp ->
3214 code = registerCode register tmp
3215 src = registerName register tmp
3216 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3218 returnNat (Any IntRep code__2)
3221 trivialFCode _ instr x y
3222 = getRegister x `thenNat` \ register1 ->
3223 getRegister y `thenNat` \ register2 ->
3224 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3225 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3227 code1 = registerCode register1 tmp1
3228 src1 = registerName register1 tmp1
3230 code2 = registerCode register2 tmp2
3231 src2 = registerName register2 tmp2
3233 code__2 dst = asmSeqThen [code1 [], code2 []] .
3234 mkSeqInstr (instr src1 src2 dst)
3236 returnNat (Any DoubleRep code__2)
3238 trivialUFCode _ instr x
3239 = getRegister x `thenNat` \ register ->
3240 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3242 code = registerCode register tmp
3243 src = registerName register tmp
3244 code__2 dst = code . mkSeqInstr (instr src dst)
3246 returnNat (Any DoubleRep code__2)
3248 #endif {- alpha_TARGET_ARCH -}
3250 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3252 #if i386_TARGET_ARCH
3254 The Rules of the Game are:
3256 * You cannot assume anything about the destination register dst;
3257 it may be anything, including a fixed reg.
3259 * You may compute an operand into a fixed reg, but you may not
3260 subsequently change the contents of that fixed reg. If you
3261 want to do so, first copy the value either to a temporary
3262 or into dst. You are free to modify dst even if it happens
3263 to be a fixed reg -- that's not your problem.
3265 * You cannot assume that a fixed reg will stay live over an
3266 arbitrary computation. The same applies to the dst reg.
3268 * Temporary regs obtained from getNewRegNCG are distinct from
3269 each other and from all other regs, and stay live over
3270 arbitrary computations.
3274 trivialCode instr maybe_revinstr a b
3277 = getRegister a `thenNat` \ rega ->
3280 then registerCode rega dst `bind` \ code_a ->
3282 instr (OpImm imm_b) (OpReg dst)
3283 else registerCodeF rega `bind` \ code_a ->
3284 registerNameF rega `bind` \ r_a ->
3286 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3287 instr (OpImm imm_b) (OpReg dst)
3289 returnNat (Any IntRep mkcode)
3292 = getRegister b `thenNat` \ regb ->
3293 getNewRegNCG IntRep `thenNat` \ tmp ->
3294 let revinstr_avail = maybeToBool maybe_revinstr
3295 revinstr = case maybe_revinstr of Just ri -> ri
3299 then registerCode regb dst `bind` \ code_b ->
3301 revinstr (OpImm imm_a) (OpReg dst)
3302 else registerCodeF regb `bind` \ code_b ->
3303 registerNameF regb `bind` \ r_b ->
3305 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3306 revinstr (OpImm imm_a) (OpReg dst)
3310 then registerCode regb tmp `bind` \ code_b ->
3312 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3313 instr (OpReg tmp) (OpReg dst)
3314 else registerCodeF regb `bind` \ code_b ->
3315 registerNameF regb `bind` \ r_b ->
3317 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3318 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3319 instr (OpReg tmp) (OpReg dst)
3321 returnNat (Any IntRep mkcode)
3324 = getRegister a `thenNat` \ rega ->
3325 getRegister b `thenNat` \ regb ->
3326 getNewRegNCG IntRep `thenNat` \ tmp ->
3328 = case (isAny rega, isAny regb) of
3330 -> registerCode regb tmp `bind` \ code_b ->
3331 registerCode rega dst `bind` \ code_a ->
3334 instr (OpReg tmp) (OpReg dst)
3336 -> registerCode rega tmp `bind` \ code_a ->
3337 registerCodeF regb `bind` \ code_b ->
3338 registerNameF regb `bind` \ r_b ->
3341 instr (OpReg r_b) (OpReg tmp) `snocOL`
3342 MOV L (OpReg tmp) (OpReg dst)
3344 -> registerCode regb tmp `bind` \ code_b ->
3345 registerCodeF rega `bind` \ code_a ->
3346 registerNameF rega `bind` \ r_a ->
3349 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3350 instr (OpReg tmp) (OpReg dst)
3352 -> registerCodeF rega `bind` \ code_a ->
3353 registerNameF rega `bind` \ r_a ->
3354 registerCodeF regb `bind` \ code_b ->
3355 registerNameF regb `bind` \ r_b ->
3357 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3359 instr (OpReg r_b) (OpReg tmp) `snocOL`
3360 MOV L (OpReg tmp) (OpReg dst)
3362 returnNat (Any IntRep mkcode)
3365 maybe_imm_a = maybeImm a
3366 is_imm_a = maybeToBool maybe_imm_a
3367 imm_a = case maybe_imm_a of Just imm -> imm
3369 maybe_imm_b = maybeImm b
3370 is_imm_b = maybeToBool maybe_imm_b
3371 imm_b = case maybe_imm_b of Just imm -> imm
3375 trivialUCode instr x
3376 = getRegister x `thenNat` \ register ->
3378 code__2 dst = let code = registerCode register dst
3379 src = registerName register dst
3381 if isFixed register && dst /= src
3382 then toOL [MOV L (OpReg src) (OpReg dst),
3384 else unitOL (instr (OpReg src))
3386 returnNat (Any IntRep code__2)
3389 trivialFCode pk instr x y
3390 = getRegister x `thenNat` \ register1 ->
3391 getRegister y `thenNat` \ register2 ->
3392 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3393 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3395 code1 = registerCode register1 tmp1
3396 src1 = registerName register1 tmp1
3398 code2 = registerCode register2 tmp2
3399 src2 = registerName register2 tmp2
3402 -- treat the common case specially: both operands in
3404 | isAny register1 && isAny register2
3407 instr (primRepToSize pk) src1 src2 dst
3409 -- be paranoid (and inefficient)
3411 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3413 instr (primRepToSize pk) tmp1 src2 dst
3415 returnNat (Any pk code__2)
3419 trivialUFCode pk instr x
3420 = getRegister x `thenNat` \ register ->
3421 getNewRegNCG pk `thenNat` \ tmp ->
3423 code = registerCode register tmp
3424 src = registerName register tmp
3425 code__2 dst = code `snocOL` instr src dst
3427 returnNat (Any pk code__2)
3429 #endif {- i386_TARGET_ARCH -}
3431 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3433 #if sparc_TARGET_ARCH
3435 trivialCode instr x (StInt y)
3437 = getRegister x `thenNat` \ register ->
3438 getNewRegNCG IntRep `thenNat` \ tmp ->
3440 code = registerCode register tmp
3441 src1 = registerName register tmp
3442 src2 = ImmInt (fromInteger y)
3443 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3445 returnNat (Any IntRep code__2)
3447 trivialCode instr x y
3448 = getRegister x `thenNat` \ register1 ->
3449 getRegister y `thenNat` \ register2 ->
3450 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3451 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3453 code1 = registerCode register1 tmp1
3454 src1 = registerName register1 tmp1
3455 code2 = registerCode register2 tmp2
3456 src2 = registerName register2 tmp2
3457 code__2 dst = code1 `appOL` code2 `snocOL`
3458 instr src1 (RIReg src2) dst
3460 returnNat (Any IntRep code__2)
3463 trivialFCode pk instr x y
3464 = getRegister x `thenNat` \ register1 ->
3465 getRegister y `thenNat` \ register2 ->
3466 getNewRegNCG (registerRep register1)
3468 getNewRegNCG (registerRep register2)
3470 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3472 promote x = FxTOy F DF x tmp
3474 pk1 = registerRep register1
3475 code1 = registerCode register1 tmp1
3476 src1 = registerName register1 tmp1
3478 pk2 = registerRep register2
3479 code2 = registerCode register2 tmp2
3480 src2 = registerName register2 tmp2
3484 code1 `appOL` code2 `snocOL`
3485 instr (primRepToSize pk) src1 src2 dst
3486 else if pk1 == FloatRep then
3487 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3488 instr DF tmp src2 dst
3490 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3491 instr DF src1 tmp dst
3493 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3496 trivialUCode instr x
3497 = getRegister x `thenNat` \ register ->
3498 getNewRegNCG IntRep `thenNat` \ tmp ->
3500 code = registerCode register tmp
3501 src = registerName register tmp
3502 code__2 dst = code `snocOL` instr (RIReg src) dst
3504 returnNat (Any IntRep code__2)
3507 trivialUFCode pk instr x
3508 = getRegister x `thenNat` \ register ->
3509 getNewRegNCG pk `thenNat` \ tmp ->
3511 code = registerCode register tmp
3512 src = registerName register tmp
3513 code__2 dst = code `snocOL` instr src dst
3515 returnNat (Any pk code__2)
3517 #endif {- sparc_TARGET_ARCH -}
3519 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3522 %************************************************************************
3524 \subsubsection{Coercing to/from integer/floating-point...}
3526 %************************************************************************
3528 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3529 conversions. We have to store temporaries in memory to move
3530 between the integer and the floating point register sets.
3532 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3533 pretend, on sparc at least, that double and float regs are seperate
3534 kinds, so the value has to be computed into one kind before being
3535 explicitly "converted" to live in the other kind.
3538 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3539 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3541 coerceDbl2Flt :: StixExpr -> NatM Register
3542 coerceFlt2Dbl :: StixExpr -> NatM Register
3546 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3548 #if alpha_TARGET_ARCH
3551 = getRegister x `thenNat` \ register ->
3552 getNewRegNCG IntRep `thenNat` \ reg ->
3554 code = registerCode register reg
3555 src = registerName register reg
3557 code__2 dst = code . mkSeqInstrs [
3559 LD TF dst (spRel 0),
3562 returnNat (Any DoubleRep code__2)
3566 = getRegister x `thenNat` \ register ->
3567 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3569 code = registerCode register tmp
3570 src = registerName register tmp
3572 code__2 dst = code . mkSeqInstrs [
3574 ST TF tmp (spRel 0),
3577 returnNat (Any IntRep code__2)
3579 #endif {- alpha_TARGET_ARCH -}
3581 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3583 #if i386_TARGET_ARCH
3586 = getRegister x `thenNat` \ register ->
3587 getNewRegNCG IntRep `thenNat` \ reg ->
3589 code = registerCode register reg
3590 src = registerName register reg
3591 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3592 code__2 dst = code `snocOL` opc src dst
3594 returnNat (Any pk code__2)
3597 coerceFP2Int fprep x
3598 = getRegister x `thenNat` \ register ->
3599 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3601 code = registerCode register tmp
3602 src = registerName register tmp
3603 pk = registerRep register
3605 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3606 code__2 dst = code `snocOL` opc src dst
3608 returnNat (Any IntRep code__2)
3611 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3612 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3614 #endif {- i386_TARGET_ARCH -}
3616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3618 #if sparc_TARGET_ARCH
3621 = getRegister x `thenNat` \ register ->
3622 getNewRegNCG IntRep `thenNat` \ reg ->
3624 code = registerCode register reg
3625 src = registerName register reg
3627 code__2 dst = code `appOL` toOL [
3628 ST W src (spRel (-2)),
3629 LD W (spRel (-2)) dst,
3630 FxTOy W (primRepToSize pk) dst dst]
3632 returnNat (Any pk code__2)
3635 coerceFP2Int fprep x
3636 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3637 getRegister x `thenNat` \ register ->
3638 getNewRegNCG fprep `thenNat` \ reg ->
3639 getNewRegNCG FloatRep `thenNat` \ tmp ->
3641 code = registerCode register reg
3642 src = registerName register reg
3643 code__2 dst = code `appOL` toOL [
3644 FxTOy (primRepToSize fprep) W src tmp,
3645 ST W tmp (spRel (-2)),
3646 LD W (spRel (-2)) dst]
3648 returnNat (Any IntRep code__2)
3652 = getRegister x `thenNat` \ register ->
3653 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3654 let code = registerCode register tmp
3655 src = registerName register tmp
3657 returnNat (Any FloatRep
3658 (\dst -> code `snocOL` FxTOy DF F src dst))
3662 = getRegister x `thenNat` \ register ->
3663 getNewRegNCG FloatRep `thenNat` \ tmp ->
3664 let code = registerCode register tmp
3665 src = registerName register tmp
3667 returnNat (Any DoubleRep
3668 (\dst -> code `snocOL` FxTOy F DF src dst))
3670 #endif {- sparc_TARGET_ARCH -}
3672 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -