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 )
56 @InstrBlock@s are the insn sequences generated by the insn selectors.
57 They are really trees of insns to facilitate fast appending, where a
58 left-to-right traversal (pre-order?) yields the insns in the correct
62 type InstrBlock = OrdList Instr
67 Code extractor for an entire stix tree---stix statement level.
70 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
72 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
73 returnNat (concatOL instrss)
76 stmtToInstrs :: StixStmt -> NatM InstrBlock
77 stmtToInstrs stmt = case stmt of
78 StComment s -> returnNat (unitOL (COMMENT s))
79 StSegment seg -> returnNat (unitOL (SEGMENT seg))
81 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
83 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
86 StLabel lab -> returnNat (unitOL (LABEL lab))
88 StJump dsts arg -> genJump dsts (derefDLL arg)
89 StCondJump lab arg -> genCondJump lab (derefDLL arg)
91 -- A call returning void, ie one done for its side-effects. Note
92 -- that this is the only StVoidable we handle.
93 StVoidable (StCall fn cconv VoidRep args)
94 -> genCCall fn cconv VoidRep (map derefDLL args)
96 StAssignMem pk addr src
97 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
99 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
100 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
101 StAssignReg pk reg src
102 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
103 | ncg_target_is_32bit
104 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
105 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
108 -- When falling through on the Alpha, we still have to load pv
109 -- with the address of the next routine, so that it can load gp.
110 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
114 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
115 returnNat (DATA (primRepToSize kind) imms
116 `consOL` concatOL codes)
118 getData :: StixExpr -> NatM (InstrBlock, Imm)
119 getData (StInt i) = returnNat (nilOL, ImmInteger i)
120 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
121 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
122 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
123 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
124 -- the linker can handle simple arithmetic...
125 getData (StIndex rep (StCLbl lbl) (StInt off)) =
127 ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
129 -- Top-level lifted-out string. The segment will already have been set
130 -- (see Stix.liftStrings).
132 -> returnNat (unitOL (ASCII True (_UNPK_ str)))
135 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
138 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
139 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
140 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
142 derefDLL :: StixExpr -> StixExpr
144 | opt_Static -- short out the entire deal if not doing DLLs
151 StCLbl lbl -> if labelDynamic lbl
152 then StInd PtrRep (StCLbl lbl)
154 -- all the rest are boring
155 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
156 StMachOp mop args -> StMachOp mop (map qq args)
157 StInd pk addr -> StInd pk (qq addr)
158 StCall who cc pk args -> StCall who cc pk (map qq args)
164 _ -> pprPanic "derefDLL: unhandled case"
168 %************************************************************************
170 \subsection{General things for putting together code sequences}
172 %************************************************************************
175 mangleIndexTree :: StixExpr -> StixExpr
177 mangleIndexTree (StIndex pk base (StInt i))
178 = StMachOp MO_Nat_Add [base, off]
180 off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
182 mangleIndexTree (StIndex pk base off)
183 = StMachOp MO_Nat_Add [
186 in if s == 0 then off
187 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
190 shift :: PrimRep -> Int
191 shift rep = case getPrimRepArrayElemSize rep of
196 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
197 (Outputable.int other)
201 maybeImm :: StixExpr -> Maybe Imm
205 maybeImm (StIndex rep (StCLbl l) (StInt off))
206 = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
208 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
209 = Just (ImmInt (fromInteger i))
211 = Just (ImmInteger i)
216 %************************************************************************
218 \subsection{The @Register64@ type}
220 %************************************************************************
222 Simple support for generating 64-bit code (ie, 64 bit values and 64
223 bit assignments) on 32-bit platforms. Unlike the main code generator
224 we merely shoot for generating working code as simply as possible, and
225 pay little attention to code quality. Specifically, there is no
226 attempt to deal cleverly with the fixed-vs-floating register
227 distinction; all values are generated into (pairs of) floating
228 registers, even if this would mean some redundant reg-reg moves as a
229 result. Only one of the VRegUniques is returned, since it will be
230 of the VRegUniqueLo form, and the upper-half VReg can be determined
231 by applying getHiVRegFromLo to it.
235 data ChildCode64 -- a.k.a "Register64"
238 VRegUnique -- unique for the lower 32-bit temporary
239 -- which contains the result; use getHiVRegFromLo to find
240 -- the other VRegUnique.
241 -- Rules of this simplified insn selection game are
242 -- therefore that the returned VRegUnique may be modified
244 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
245 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
246 iselExpr64 :: StixExpr -> NatM ChildCode64
248 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
252 assignMem_I64Code addrTree valueTree
253 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
254 getRegister addrTree `thenNat` \ register_addr ->
255 getNewRegNCG IntRep `thenNat` \ t_addr ->
256 let rlo = VirtualRegI vrlo
257 rhi = getHiVRegFromLo rlo
258 code_addr = registerCode register_addr t_addr
259 reg_addr = registerName register_addr t_addr
260 -- Little-endian store
261 mov_lo = MOV L (OpReg rlo)
262 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
263 mov_hi = MOV L (OpReg rhi)
264 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
266 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
268 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
269 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
271 r_dst_lo = mkVReg u_dst IntRep
272 r_src_lo = VirtualRegI vr_src_lo
273 r_dst_hi = getHiVRegFromLo r_dst_lo
274 r_src_hi = getHiVRegFromLo r_src_lo
275 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
276 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
279 vcode `snocOL` mov_lo `snocOL` mov_hi
282 assignReg_I64Code lvalue valueTree
283 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
288 iselExpr64 (StInd pk addrTree)
290 = getRegister addrTree `thenNat` \ register_addr ->
291 getNewRegNCG IntRep `thenNat` \ t_addr ->
292 getNewRegNCG IntRep `thenNat` \ rlo ->
293 let rhi = getHiVRegFromLo rlo
294 code_addr = registerCode register_addr t_addr
295 reg_addr = registerName register_addr t_addr
296 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
298 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
302 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
306 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
308 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
309 let r_dst_hi = getHiVRegFromLo r_dst_lo
310 r_src_lo = mkVReg vu IntRep
311 r_src_hi = getHiVRegFromLo r_src_lo
312 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
313 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
316 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
319 iselExpr64 (StCall fn cconv kind args)
321 = genCCall fn cconv kind args `thenNat` \ call ->
322 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
323 let r_dst_hi = getHiVRegFromLo r_dst_lo
324 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
325 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
328 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
329 (getVRegUnique r_dst_lo)
333 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
335 #endif {- i386_TARGET_ARCH -}
337 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
339 #if sparc_TARGET_ARCH
341 assignMem_I64Code addrTree valueTree
342 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
343 getRegister addrTree `thenNat` \ register_addr ->
344 getNewRegNCG IntRep `thenNat` \ t_addr ->
345 let rlo = VirtualRegI vrlo
346 rhi = getHiVRegFromLo rlo
347 code_addr = registerCode register_addr t_addr
348 reg_addr = registerName register_addr t_addr
350 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
351 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
353 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
356 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
357 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
359 r_dst_lo = mkVReg u_dst IntRep
360 r_src_lo = VirtualRegI vr_src_lo
361 r_dst_hi = getHiVRegFromLo r_dst_lo
362 r_src_hi = getHiVRegFromLo r_src_lo
363 mov_lo = mkMOV r_src_lo r_dst_lo
364 mov_hi = mkMOV r_src_hi r_dst_hi
365 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
368 vcode `snocOL` mov_hi `snocOL` mov_lo
370 assignReg_I64Code lvalue valueTree
371 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
375 -- Don't delete this -- it's very handy for debugging.
377 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
378 -- = panic "iselExpr64(???)"
380 iselExpr64 (StInd pk addrTree)
382 = getRegister addrTree `thenNat` \ register_addr ->
383 getNewRegNCG IntRep `thenNat` \ t_addr ->
384 getNewRegNCG IntRep `thenNat` \ rlo ->
385 let rhi = getHiVRegFromLo rlo
386 code_addr = registerCode register_addr t_addr
387 reg_addr = registerName register_addr t_addr
388 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
389 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
392 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
396 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
398 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
399 let r_dst_hi = getHiVRegFromLo r_dst_lo
400 r_src_lo = mkVReg vu IntRep
401 r_src_hi = getHiVRegFromLo r_src_lo
402 mov_lo = mkMOV r_src_lo r_dst_lo
403 mov_hi = mkMOV r_src_hi r_dst_hi
404 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
407 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
410 iselExpr64 (StCall fn cconv kind args)
412 = genCCall fn cconv kind args `thenNat` \ call ->
413 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
414 let r_dst_hi = getHiVRegFromLo r_dst_lo
415 mov_lo = mkMOV o0 r_dst_lo
416 mov_hi = mkMOV o1 r_dst_hi
417 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
420 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
421 (getVRegUnique r_dst_lo)
425 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
427 #endif {- sparc_TARGET_ARCH -}
429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
433 %************************************************************************
435 \subsection{The @Register@ type}
437 %************************************************************************
439 @Register@s passed up the tree. If the stix code forces the register
440 to live in a pre-decided machine register, it comes out as @Fixed@;
441 otherwise, it comes out as @Any@, and the parent can decide which
442 register to put it in.
446 = Fixed PrimRep Reg InstrBlock
447 | Any PrimRep (Reg -> InstrBlock)
449 registerCode :: Register -> Reg -> InstrBlock
450 registerCode (Fixed _ _ code) reg = code
451 registerCode (Any _ code) reg = code reg
453 registerCodeF (Fixed _ _ code) = code
454 registerCodeF (Any _ _) = panic "registerCodeF"
456 registerCodeA (Any _ code) = code
457 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
459 registerName :: Register -> Reg -> Reg
460 registerName (Fixed _ reg _) _ = reg
461 registerName (Any _ _) reg = reg
463 registerNameF (Fixed _ reg _) = reg
464 registerNameF (Any _ _) = panic "registerNameF"
466 registerRep :: Register -> PrimRep
467 registerRep (Fixed pk _ _) = pk
468 registerRep (Any pk _) = pk
470 swizzleRegisterRep :: Register -> PrimRep -> Register
471 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
472 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
474 {-# INLINE registerCode #-}
475 {-# INLINE registerCodeF #-}
476 {-# INLINE registerName #-}
477 {-# INLINE registerNameF #-}
478 {-# INLINE registerRep #-}
479 {-# INLINE isFixed #-}
482 isFixed, isAny :: Register -> Bool
483 isFixed (Fixed _ _ _) = True
484 isFixed (Any _ _) = False
486 isAny = not . isFixed
489 Generate code to get a subtree into a @Register@:
492 getRegisterReg :: StixReg -> NatM Register
493 getRegister :: StixExpr -> NatM Register
496 getRegisterReg (StixMagicId mid)
497 = case get_MagicId_reg_or_addr mid of
499 -> let pk = magicIdPrimRep mid
500 in returnNat (Fixed pk (RealReg rrno) nilOL)
502 -- By this stage, the only MagicIds remaining should be the
503 -- ones which map to a real machine register on this platform. Hence ...
504 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
506 getRegisterReg (StixTemp (StixVReg u pk))
507 = returnNat (Fixed pk (mkVReg u pk) nilOL)
511 -- Don't delete this -- it's very handy for debugging.
513 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
514 -- = panic "getRegister(???)"
516 getRegister (StReg reg)
519 getRegister tree@(StIndex _ _ _)
520 = getRegister (mangleIndexTree tree)
522 getRegister (StCall fn cconv kind args)
523 | not (ncg_target_is_32bit && is64BitRep kind)
524 = genCCall fn cconv kind args `thenNat` \ call ->
525 returnNat (Fixed kind reg call)
527 reg = if isFloatingRep kind
528 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
529 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
531 getRegister (StString s)
532 = getNatLabelNCG `thenNat` \ lbl ->
534 imm_lbl = ImmCLbl lbl
537 SEGMENT RoDataSegment,
539 ASCII True (_UNPK_ s),
541 #if alpha_TARGET_ARCH
542 LDA dst (AddrImm imm_lbl)
545 MOV L (OpImm imm_lbl) (OpReg dst)
547 #if sparc_TARGET_ARCH
548 SETHI (HI imm_lbl) dst,
549 OR False dst (RIImm (LO imm_lbl)) dst
553 returnNat (Any PtrRep code)
555 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
556 -- end of machine-"independent" bit; here we go on the rest...
558 #if alpha_TARGET_ARCH
560 getRegister (StDouble d)
561 = getNatLabelNCG `thenNat` \ lbl ->
562 getNewRegNCG PtrRep `thenNat` \ tmp ->
563 let code dst = mkSeqInstrs [
566 DATA TF [ImmLab (rational d)],
568 LDA tmp (AddrImm (ImmCLbl lbl)),
569 LD TF dst (AddrReg tmp)]
571 returnNat (Any DoubleRep code)
573 getRegister (StPrim primop [x]) -- unary PrimOps
575 IntNegOp -> trivialUCode (NEG Q False) x
577 NotOp -> trivialUCode NOT x
579 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
580 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
582 OrdOp -> coerceIntCode IntRep x
585 Float2IntOp -> coerceFP2Int x
586 Int2FloatOp -> coerceInt2FP pr x
587 Double2IntOp -> coerceFP2Int x
588 Int2DoubleOp -> coerceInt2FP pr x
590 Double2FloatOp -> coerceFltCode x
591 Float2DoubleOp -> coerceFltCode x
593 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
595 fn = case other_op of
596 FloatExpOp -> SLIT("exp")
597 FloatLogOp -> SLIT("log")
598 FloatSqrtOp -> SLIT("sqrt")
599 FloatSinOp -> SLIT("sin")
600 FloatCosOp -> SLIT("cos")
601 FloatTanOp -> SLIT("tan")
602 FloatAsinOp -> SLIT("asin")
603 FloatAcosOp -> SLIT("acos")
604 FloatAtanOp -> SLIT("atan")
605 FloatSinhOp -> SLIT("sinh")
606 FloatCoshOp -> SLIT("cosh")
607 FloatTanhOp -> SLIT("tanh")
608 DoubleExpOp -> SLIT("exp")
609 DoubleLogOp -> SLIT("log")
610 DoubleSqrtOp -> SLIT("sqrt")
611 DoubleSinOp -> SLIT("sin")
612 DoubleCosOp -> SLIT("cos")
613 DoubleTanOp -> SLIT("tan")
614 DoubleAsinOp -> SLIT("asin")
615 DoubleAcosOp -> SLIT("acos")
616 DoubleAtanOp -> SLIT("atan")
617 DoubleSinhOp -> SLIT("sinh")
618 DoubleCoshOp -> SLIT("cosh")
619 DoubleTanhOp -> SLIT("tanh")
621 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
623 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
625 CharGtOp -> trivialCode (CMP LTT) y x
626 CharGeOp -> trivialCode (CMP LE) y x
627 CharEqOp -> trivialCode (CMP EQQ) x y
628 CharNeOp -> int_NE_code x y
629 CharLtOp -> trivialCode (CMP LTT) x y
630 CharLeOp -> trivialCode (CMP LE) x y
632 IntGtOp -> trivialCode (CMP LTT) y x
633 IntGeOp -> trivialCode (CMP LE) y x
634 IntEqOp -> trivialCode (CMP EQQ) x y
635 IntNeOp -> int_NE_code x y
636 IntLtOp -> trivialCode (CMP LTT) x y
637 IntLeOp -> trivialCode (CMP LE) x y
639 WordGtOp -> trivialCode (CMP ULT) y x
640 WordGeOp -> trivialCode (CMP ULE) x y
641 WordEqOp -> trivialCode (CMP EQQ) x y
642 WordNeOp -> int_NE_code x y
643 WordLtOp -> trivialCode (CMP ULT) x y
644 WordLeOp -> trivialCode (CMP ULE) x y
646 AddrGtOp -> trivialCode (CMP ULT) y x
647 AddrGeOp -> trivialCode (CMP ULE) y x
648 AddrEqOp -> trivialCode (CMP EQQ) x y
649 AddrNeOp -> int_NE_code x y
650 AddrLtOp -> trivialCode (CMP ULT) x y
651 AddrLeOp -> trivialCode (CMP ULE) x y
653 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
654 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
655 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
656 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
657 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
658 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
660 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
661 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
662 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
663 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
664 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
665 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
667 IntAddOp -> trivialCode (ADD Q False) x y
668 IntSubOp -> trivialCode (SUB Q False) x y
669 IntMulOp -> trivialCode (MUL Q False) x y
670 IntQuotOp -> trivialCode (DIV Q False) x y
671 IntRemOp -> trivialCode (REM Q False) x y
673 WordAddOp -> trivialCode (ADD Q False) x y
674 WordSubOp -> trivialCode (SUB Q False) x y
675 WordMulOp -> trivialCode (MUL Q False) x y
676 WordQuotOp -> trivialCode (DIV Q True) x y
677 WordRemOp -> trivialCode (REM Q True) x y
679 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
680 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
681 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
682 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
684 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
685 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
686 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
687 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
689 AddrAddOp -> trivialCode (ADD Q False) x y
690 AddrSubOp -> trivialCode (SUB Q False) x y
691 AddrRemOp -> trivialCode (REM Q True) x y
693 AndOp -> trivialCode AND x y
694 OrOp -> trivialCode OR x y
695 XorOp -> trivialCode XOR x y
696 SllOp -> trivialCode SLL x y
697 SrlOp -> trivialCode SRL x y
699 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
700 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
701 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
703 FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
704 DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
706 {- ------------------------------------------------------------
707 Some bizarre special code for getting condition codes into
708 registers. Integer non-equality is a test for equality
709 followed by an XOR with 1. (Integer comparisons always set
710 the result register to 0 or 1.) Floating point comparisons of
711 any kind leave the result in a floating point register, so we
712 need to wrangle an integer register out of things.
714 int_NE_code :: StixTree -> StixTree -> NatM Register
717 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
718 getNewRegNCG IntRep `thenNat` \ tmp ->
720 code = registerCode register tmp
721 src = registerName register tmp
722 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
724 returnNat (Any IntRep code__2)
726 {- ------------------------------------------------------------
727 Comments for int_NE_code also apply to cmpF_code
730 :: (Reg -> Reg -> Reg -> Instr)
732 -> StixTree -> StixTree
735 cmpF_code instr cond x y
736 = trivialFCode pr instr x y `thenNat` \ register ->
737 getNewRegNCG DoubleRep `thenNat` \ tmp ->
738 getNatLabelNCG `thenNat` \ lbl ->
740 code = registerCode register tmp
741 result = registerName register tmp
743 code__2 dst = code . mkSeqInstrs [
744 OR zeroh (RIImm (ImmInt 1)) dst,
745 BF cond result (ImmCLbl lbl),
746 OR zeroh (RIReg zeroh) dst,
749 returnNat (Any IntRep code__2)
751 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
752 ------------------------------------------------------------
754 getRegister (StInd pk mem)
755 = getAmode mem `thenNat` \ amode ->
757 code = amodeCode amode
758 src = amodeAddr amode
759 size = primRepToSize pk
760 code__2 dst = code . mkSeqInstr (LD size dst src)
762 returnNat (Any pk code__2)
764 getRegister (StInt i)
767 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
769 returnNat (Any IntRep code)
772 code dst = mkSeqInstr (LDI Q dst src)
774 returnNat (Any IntRep code)
776 src = ImmInt (fromInteger i)
781 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
783 returnNat (Any PtrRep code)
786 imm__2 = case imm of Just x -> x
788 #endif {- alpha_TARGET_ARCH -}
790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
794 getRegister (StFloat f)
795 = getNatLabelNCG `thenNat` \ lbl ->
796 let code dst = toOL [
801 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
804 returnNat (Any FloatRep code)
807 getRegister (StDouble d)
810 = let code dst = unitOL (GLDZ dst)
811 in returnNat (Any DoubleRep code)
814 = let code dst = unitOL (GLD1 dst)
815 in returnNat (Any DoubleRep code)
818 = getNatLabelNCG `thenNat` \ lbl ->
819 let code dst = toOL [
822 DATA DF [ImmDouble d],
824 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
827 returnNat (Any DoubleRep code)
830 getRegister (StMachOp mop [x]) -- unary MachOps
832 MO_NatS_Neg -> trivialUCode (NEGI L) x
833 MO_Nat_Not -> trivialUCode (NOT L) x
835 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
836 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
838 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
839 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
841 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
842 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
844 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
845 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
847 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
848 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
850 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
851 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
852 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
853 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
855 -- Conversions which are a nop on x86
856 MO_NatS_to_32U -> conversionNop WordRep x
857 MO_32U_to_NatS -> conversionNop IntRep x
859 MO_NatU_to_NatS -> conversionNop IntRep x
860 MO_NatS_to_NatU -> conversionNop WordRep x
861 MO_NatP_to_NatU -> conversionNop WordRep x
862 MO_NatU_to_NatP -> conversionNop PtrRep x
863 MO_NatS_to_NatP -> conversionNop PtrRep x
864 MO_NatP_to_NatS -> conversionNop IntRep x
866 MO_Dbl_to_Flt -> conversionNop FloatRep x
867 MO_Flt_to_Dbl -> conversionNop DoubleRep x
869 -- sign-extending widenings
870 MO_8U_to_NatU -> integerExtend False 24 x
871 MO_8S_to_NatS -> integerExtend True 24 x
872 MO_16U_to_NatU -> integerExtend False 16 x
873 MO_16S_to_NatS -> integerExtend True 16 x
877 (if is_float_op then demote else id)
878 (StCall fn CCallConv DoubleRep
879 [(if is_float_op then promote else id) x])
882 integerExtend signed nBits x
884 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
885 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
888 conversionNop new_rep expr
889 = getRegister expr `thenNat` \ e_code ->
890 returnNat (swizzleRegisterRep e_code new_rep)
892 promote x = StMachOp MO_Flt_to_Dbl [x]
893 demote x = StMachOp MO_Dbl_to_Flt [x]
896 MO_Flt_Exp -> (True, SLIT("exp"))
897 MO_Flt_Log -> (True, SLIT("log"))
899 MO_Flt_Asin -> (True, SLIT("asin"))
900 MO_Flt_Acos -> (True, SLIT("acos"))
901 MO_Flt_Atan -> (True, SLIT("atan"))
903 MO_Flt_Sinh -> (True, SLIT("sinh"))
904 MO_Flt_Cosh -> (True, SLIT("cosh"))
905 MO_Flt_Tanh -> (True, SLIT("tanh"))
907 MO_Dbl_Exp -> (False, SLIT("exp"))
908 MO_Dbl_Log -> (False, SLIT("log"))
910 MO_Dbl_Asin -> (False, SLIT("asin"))
911 MO_Dbl_Acos -> (False, SLIT("acos"))
912 MO_Dbl_Atan -> (False, SLIT("atan"))
914 MO_Dbl_Sinh -> (False, SLIT("sinh"))
915 MO_Dbl_Cosh -> (False, SLIT("cosh"))
916 MO_Dbl_Tanh -> (False, SLIT("tanh"))
918 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
922 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
924 MO_32U_Gt -> condIntReg GTT x y
925 MO_32U_Ge -> condIntReg GE x y
926 MO_32U_Eq -> condIntReg EQQ x y
927 MO_32U_Ne -> condIntReg NE x y
928 MO_32U_Lt -> condIntReg LTT x y
929 MO_32U_Le -> condIntReg LE x y
931 MO_Nat_Eq -> condIntReg EQQ x y
932 MO_Nat_Ne -> condIntReg NE x y
934 MO_NatS_Gt -> condIntReg GTT x y
935 MO_NatS_Ge -> condIntReg GE x y
936 MO_NatS_Lt -> condIntReg LTT x y
937 MO_NatS_Le -> condIntReg LE x y
939 MO_NatU_Gt -> condIntReg GU x y
940 MO_NatU_Ge -> condIntReg GEU x y
941 MO_NatU_Lt -> condIntReg LU x y
942 MO_NatU_Le -> condIntReg LEU x y
944 MO_Flt_Gt -> condFltReg GTT x y
945 MO_Flt_Ge -> condFltReg GE x y
946 MO_Flt_Eq -> condFltReg EQQ x y
947 MO_Flt_Ne -> condFltReg NE x y
948 MO_Flt_Lt -> condFltReg LTT x y
949 MO_Flt_Le -> condFltReg LE x y
951 MO_Dbl_Gt -> condFltReg GTT x y
952 MO_Dbl_Ge -> condFltReg GE x y
953 MO_Dbl_Eq -> condFltReg EQQ x y
954 MO_Dbl_Ne -> condFltReg NE x y
955 MO_Dbl_Lt -> condFltReg LTT x y
956 MO_Dbl_Le -> condFltReg LE x y
958 MO_Nat_Add -> add_code L x y
959 MO_Nat_Sub -> sub_code L x y
960 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
961 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
962 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
963 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
964 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
965 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
966 MO_NatS_MulMayOflo -> imulMayOflo x y
968 MO_Flt_Add -> trivialFCode FloatRep GADD x y
969 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
970 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
971 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
973 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
974 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
975 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
976 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
978 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
979 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
980 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
982 {- Shift ops on x86s have constraints on their source, it
983 either has to be Imm, CL or 1
984 => trivialCode's is not restrictive enough (sigh.)
986 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
987 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
988 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
990 MO_Flt_Pwr -> getRegister (demote
991 (StCall SLIT("pow") CCallConv DoubleRep
992 [promote x, promote y])
994 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
996 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
998 promote x = StMachOp MO_Flt_to_Dbl [x]
999 demote x = StMachOp MO_Dbl_to_Flt [x]
1001 --------------------
1002 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1004 = getNewRegNCG IntRep `thenNat` \ t1 ->
1005 getNewRegNCG IntRep `thenNat` \ t2 ->
1006 getNewRegNCG IntRep `thenNat` \ res_lo ->
1007 getNewRegNCG IntRep `thenNat` \ res_hi ->
1008 getRegister a1 `thenNat` \ reg1 ->
1009 getRegister a2 `thenNat` \ reg2 ->
1010 let code1 = registerCode reg1 t1
1011 code2 = registerCode reg2 t2
1012 src1 = registerName reg1 t1
1013 src2 = registerName reg2 t2
1015 MOV L (OpReg src1) (OpReg res_hi),
1016 MOV L (OpReg src2) (OpReg res_lo),
1017 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1018 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1019 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1020 MOV L (OpReg res_lo) (OpReg dst)
1021 -- dst==0 if high part == sign extended low part
1024 returnNat (Any IntRep code)
1026 --------------------
1027 shift_code :: (Imm -> Operand -> Instr)
1032 {- Case1: shift length as immediate -}
1033 -- Code is the same as the first eq. for trivialCode -- sigh.
1034 shift_code instr x y{-amount-}
1036 = getRegister x `thenNat` \ regx ->
1039 then registerCodeA regx dst `bind` \ code_x ->
1041 instr imm__2 (OpReg dst)
1042 else registerCodeF regx `bind` \ code_x ->
1043 registerNameF regx `bind` \ r_x ->
1045 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1046 instr imm__2 (OpReg dst)
1048 returnNat (Any IntRep mkcode)
1051 imm__2 = case imm of Just x -> x
1053 {- Case2: shift length is complex (non-immediate) -}
1054 -- Since ECX is always used as a spill temporary, we can't
1055 -- use it here to do non-immediate shifts. No big deal --
1056 -- they are only very rare, and we can use an equivalent
1057 -- test-and-jump sequence which doesn't use ECX.
1058 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1059 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1060 shift_code instr x y{-amount-}
1061 = getRegister x `thenNat` \ register1 ->
1062 getRegister y `thenNat` \ register2 ->
1063 getNatLabelNCG `thenNat` \ lbl_test3 ->
1064 getNatLabelNCG `thenNat` \ lbl_test2 ->
1065 getNatLabelNCG `thenNat` \ lbl_test1 ->
1066 getNatLabelNCG `thenNat` \ lbl_test0 ->
1067 getNatLabelNCG `thenNat` \ lbl_after ->
1068 getNewRegNCG IntRep `thenNat` \ tmp ->
1070 = let src_val = registerName register1 dst
1071 code_val = registerCode register1 dst
1072 src_amt = registerName register2 tmp
1073 code_amt = registerCode register2 tmp
1078 MOV L (OpReg src_amt) r_tmp `appOL`
1080 MOV L (OpReg src_val) r_dst `appOL`
1082 COMMENT (_PK_ "begin shift sequence"),
1083 MOV L (OpReg src_val) r_dst,
1084 MOV L (OpReg src_amt) r_tmp,
1086 BT L (ImmInt 4) r_tmp,
1088 instr (ImmInt 16) r_dst,
1091 BT L (ImmInt 3) r_tmp,
1093 instr (ImmInt 8) r_dst,
1096 BT L (ImmInt 2) r_tmp,
1098 instr (ImmInt 4) r_dst,
1101 BT L (ImmInt 1) r_tmp,
1103 instr (ImmInt 2) r_dst,
1106 BT L (ImmInt 0) r_tmp,
1108 instr (ImmInt 1) r_dst,
1111 COMMENT (_PK_ "end shift sequence")
1114 returnNat (Any IntRep code__2)
1116 --------------------
1117 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1119 add_code sz x (StInt y)
1120 = getRegister x `thenNat` \ register ->
1121 getNewRegNCG IntRep `thenNat` \ tmp ->
1123 code = registerCode register tmp
1124 src1 = registerName register tmp
1125 src2 = ImmInt (fromInteger y)
1128 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1131 returnNat (Any IntRep code__2)
1133 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1135 --------------------
1136 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1138 sub_code sz x (StInt y)
1139 = getRegister x `thenNat` \ register ->
1140 getNewRegNCG IntRep `thenNat` \ tmp ->
1142 code = registerCode register tmp
1143 src1 = registerName register tmp
1144 src2 = ImmInt (-(fromInteger y))
1147 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1150 returnNat (Any IntRep code__2)
1152 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1154 getRegister (StInd pk mem)
1155 | not (is64BitRep pk)
1156 = getAmode mem `thenNat` \ amode ->
1158 code = amodeCode amode
1159 src = amodeAddr amode
1160 size = primRepToSize pk
1161 code__2 dst = code `snocOL`
1162 if pk == DoubleRep || pk == FloatRep
1163 then GLD size src dst
1171 (OpAddr src) (OpReg dst)
1173 returnNat (Any pk code__2)
1175 getRegister (StInt i)
1177 src = ImmInt (fromInteger i)
1180 = unitOL (XOR L (OpReg dst) (OpReg dst))
1182 = unitOL (MOV L (OpImm src) (OpReg dst))
1184 returnNat (Any IntRep code)
1188 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1190 returnNat (Any PtrRep code)
1192 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1195 imm__2 = case imm of Just x -> x
1197 #endif {- i386_TARGET_ARCH -}
1199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1201 #if sparc_TARGET_ARCH
1203 getRegister (StFloat d)
1204 = getNatLabelNCG `thenNat` \ lbl ->
1205 getNewRegNCG PtrRep `thenNat` \ tmp ->
1206 let code dst = toOL [
1207 SEGMENT DataSegment,
1209 DATA F [ImmFloat d],
1210 SEGMENT TextSegment,
1211 SETHI (HI (ImmCLbl lbl)) tmp,
1212 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1214 returnNat (Any FloatRep code)
1216 getRegister (StDouble d)
1217 = getNatLabelNCG `thenNat` \ lbl ->
1218 getNewRegNCG PtrRep `thenNat` \ tmp ->
1219 let code dst = toOL [
1220 SEGMENT DataSegment,
1222 DATA DF [ImmDouble d],
1223 SEGMENT TextSegment,
1224 SETHI (HI (ImmCLbl lbl)) tmp,
1225 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1227 returnNat (Any DoubleRep code)
1230 getRegister (StMachOp mop [x]) -- unary PrimOps
1232 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1233 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1235 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1236 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1238 MO_Dbl_to_Flt -> coerceDbl2Flt x
1239 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1241 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1242 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1243 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1244 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1246 -- Conversions which are a nop on sparc
1247 MO_32U_to_NatS -> conversionNop IntRep x
1248 MO_NatS_to_32U -> conversionNop WordRep x
1250 MO_NatU_to_NatS -> conversionNop IntRep x
1251 MO_NatS_to_NatU -> conversionNop WordRep x
1252 MO_NatP_to_NatU -> conversionNop WordRep x
1253 MO_NatU_to_NatP -> conversionNop PtrRep x
1254 MO_NatS_to_NatP -> conversionNop PtrRep x
1255 MO_NatP_to_NatS -> conversionNop IntRep x
1257 -- sign-extending widenings
1258 MO_8U_to_NatU -> integerExtend False 24 x
1259 MO_8S_to_NatS -> integerExtend True 24 x
1260 MO_16U_to_NatU -> integerExtend False 16 x
1261 MO_16S_to_NatS -> integerExtend True 16 x
1264 let fixed_x = if is_float_op -- promote to double
1265 then StMachOp MO_Flt_to_Dbl [x]
1268 getRegister (StCall fn CCallConv DoubleRep [fixed_x])
1270 integerExtend signed nBits x
1272 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1273 [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]]
1275 conversionNop new_rep expr
1276 = getRegister expr `thenNat` \ e_code ->
1277 returnNat (swizzleRegisterRep e_code new_rep)
1281 MO_Flt_Exp -> (True, SLIT("exp"))
1282 MO_Flt_Log -> (True, SLIT("log"))
1283 MO_Flt_Sqrt -> (True, SLIT("sqrt"))
1285 MO_Flt_Sin -> (True, SLIT("sin"))
1286 MO_Flt_Cos -> (True, SLIT("cos"))
1287 MO_Flt_Tan -> (True, SLIT("tan"))
1289 MO_Flt_Asin -> (True, SLIT("asin"))
1290 MO_Flt_Acos -> (True, SLIT("acos"))
1291 MO_Flt_Atan -> (True, SLIT("atan"))
1293 MO_Flt_Sinh -> (True, SLIT("sinh"))
1294 MO_Flt_Cosh -> (True, SLIT("cosh"))
1295 MO_Flt_Tanh -> (True, SLIT("tanh"))
1297 MO_Dbl_Exp -> (False, SLIT("exp"))
1298 MO_Dbl_Log -> (False, SLIT("log"))
1299 MO_Dbl_Sqrt -> (False, SLIT("sqrt"))
1301 MO_Dbl_Sin -> (False, SLIT("sin"))
1302 MO_Dbl_Cos -> (False, SLIT("cos"))
1303 MO_Dbl_Tan -> (False, SLIT("tan"))
1305 MO_Dbl_Asin -> (False, SLIT("asin"))
1306 MO_Dbl_Acos -> (False, SLIT("acos"))
1307 MO_Dbl_Atan -> (False, SLIT("atan"))
1309 MO_Dbl_Sinh -> (False, SLIT("sinh"))
1310 MO_Dbl_Cosh -> (False, SLIT("cosh"))
1311 MO_Dbl_Tanh -> (False, SLIT("tanh"))
1313 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1317 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1319 MO_32U_Gt -> condIntReg GTT x y
1320 MO_32U_Ge -> condIntReg GE x y
1321 MO_32U_Eq -> condIntReg EQQ x y
1322 MO_32U_Ne -> condIntReg NE x y
1323 MO_32U_Lt -> condIntReg LTT x y
1324 MO_32U_Le -> condIntReg LE x y
1326 MO_Nat_Eq -> condIntReg EQQ x y
1327 MO_Nat_Ne -> condIntReg NE x y
1329 MO_NatS_Gt -> condIntReg GTT x y
1330 MO_NatS_Ge -> condIntReg GE x y
1331 MO_NatS_Lt -> condIntReg LTT x y
1332 MO_NatS_Le -> condIntReg LE x y
1334 MO_NatU_Gt -> condIntReg GU x y
1335 MO_NatU_Ge -> condIntReg GEU x y
1336 MO_NatU_Lt -> condIntReg LU x y
1337 MO_NatU_Le -> condIntReg LEU x y
1339 MO_Flt_Gt -> condFltReg GTT x y
1340 MO_Flt_Ge -> condFltReg GE x y
1341 MO_Flt_Eq -> condFltReg EQQ x y
1342 MO_Flt_Ne -> condFltReg NE x y
1343 MO_Flt_Lt -> condFltReg LTT x y
1344 MO_Flt_Le -> condFltReg LE x y
1346 MO_Dbl_Gt -> condFltReg GTT x y
1347 MO_Dbl_Ge -> condFltReg GE x y
1348 MO_Dbl_Eq -> condFltReg EQQ x y
1349 MO_Dbl_Ne -> condFltReg NE x y
1350 MO_Dbl_Lt -> condFltReg LTT x y
1351 MO_Dbl_Le -> condFltReg LE x y
1353 MO_Nat_Add -> trivialCode (ADD False False) x y
1354 MO_Nat_Sub -> trivialCode (SUB False False) x y
1356 -- ToDo: teach about V8+ SPARC mul/div instructions
1357 MO_NatS_Quot -> imul_div SLIT(".div") x y
1358 MO_NatS_Rem -> imul_div SLIT(".rem") x y
1359 MO_NatU_Quot -> imul_div SLIT(".udiv") x y
1360 MO_NatU_Rem -> imul_div SLIT(".urem") x y
1362 MO_NatS_Mul -> imul_div SLIT(".umul") x y
1363 MO_NatU_Mul -> imul_div SLIT(".umul") x y
1365 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1366 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1367 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1368 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1370 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1371 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1372 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1373 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1375 MO_Nat_And -> trivialCode (AND False) x y
1376 MO_Nat_Or -> trivialCode (OR False) x y
1377 MO_Nat_Xor -> trivialCode (XOR False) x y
1379 MO_Nat_Shl -> trivialCode SLL x y
1380 MO_Nat_Shr -> trivialCode SRL x y
1381 MO_Nat_Sar -> trivialCode SRA x y
1383 MO_Flt_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1384 [promote x, promote y])
1385 where promote x = StMachOp MO_Flt_to_Dbl [x]
1386 MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep
1389 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1391 imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y])
1393 getRegister (StInd pk mem)
1394 = getAmode mem `thenNat` \ amode ->
1396 code = amodeCode amode
1397 src = amodeAddr amode
1398 size = primRepToSize pk
1399 code__2 dst = code `snocOL` LD size src dst
1401 returnNat (Any pk code__2)
1403 getRegister (StInt i)
1406 src = ImmInt (fromInteger i)
1407 code dst = unitOL (OR False g0 (RIImm src) dst)
1409 returnNat (Any IntRep code)
1415 SETHI (HI imm__2) dst,
1416 OR False dst (RIImm (LO imm__2)) dst]
1418 returnNat (Any PtrRep code)
1420 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1423 imm__2 = case imm of Just x -> x
1425 #endif {- sparc_TARGET_ARCH -}
1427 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1431 %************************************************************************
1433 \subsection{The @Amode@ type}
1435 %************************************************************************
1437 @Amode@s: Memory addressing modes passed up the tree.
1439 data Amode = Amode MachRegsAddr InstrBlock
1441 amodeAddr (Amode addr _) = addr
1442 amodeCode (Amode _ code) = code
1445 Now, given a tree (the argument to an StInd) that references memory,
1446 produce a suitable addressing mode.
1448 A Rule of the Game (tm) for Amodes: use of the addr bit must
1449 immediately follow use of the code part, since the code part puts
1450 values in registers which the addr then refers to. So you can't put
1451 anything in between, lest it overwrite some of those registers. If
1452 you need to do some other computation between the code part and use of
1453 the addr bit, first store the effective address from the amode in a
1454 temporary, then do the other computation, and then use the temporary:
1458 ... other computation ...
1462 getAmode :: StixExpr -> NatM Amode
1464 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1466 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1468 #if alpha_TARGET_ARCH
1470 getAmode (StPrim IntSubOp [x, StInt i])
1471 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1472 getRegister x `thenNat` \ register ->
1474 code = registerCode register tmp
1475 reg = registerName register tmp
1476 off = ImmInt (-(fromInteger i))
1478 returnNat (Amode (AddrRegImm reg off) code)
1480 getAmode (StPrim IntAddOp [x, StInt i])
1481 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1482 getRegister x `thenNat` \ register ->
1484 code = registerCode register tmp
1485 reg = registerName register tmp
1486 off = ImmInt (fromInteger i)
1488 returnNat (Amode (AddrRegImm reg off) code)
1492 = returnNat (Amode (AddrImm imm__2) id)
1495 imm__2 = case imm of Just x -> x
1498 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1499 getRegister other `thenNat` \ register ->
1501 code = registerCode register tmp
1502 reg = registerName register tmp
1504 returnNat (Amode (AddrReg reg) code)
1506 #endif {- alpha_TARGET_ARCH -}
1508 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1510 #if i386_TARGET_ARCH
1512 -- This is all just ridiculous, since it carefully undoes
1513 -- what mangleIndexTree has just done.
1514 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1515 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1516 getRegister x `thenNat` \ register ->
1518 code = registerCode register tmp
1519 reg = registerName register tmp
1520 off = ImmInt (-(fromInteger i))
1522 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1524 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1526 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1529 imm__2 = case imm of Just x -> x
1531 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1532 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1533 getRegister x `thenNat` \ register ->
1535 code = registerCode register tmp
1536 reg = registerName register tmp
1537 off = ImmInt (fromInteger i)
1539 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1541 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1542 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1543 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1544 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1545 getRegister x `thenNat` \ register1 ->
1546 getRegister y `thenNat` \ register2 ->
1548 code1 = registerCode register1 tmp1
1549 reg1 = registerName register1 tmp1
1550 code2 = registerCode register2 tmp2
1551 reg2 = registerName register2 tmp2
1552 code__2 = code1 `appOL` code2
1553 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1555 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1560 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1563 imm__2 = case imm of Just x -> x
1566 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1567 getRegister other `thenNat` \ register ->
1569 code = registerCode register tmp
1570 reg = registerName register tmp
1572 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1574 #endif {- i386_TARGET_ARCH -}
1576 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1578 #if sparc_TARGET_ARCH
1580 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1582 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1583 getRegister x `thenNat` \ register ->
1585 code = registerCode register tmp
1586 reg = registerName register tmp
1587 off = ImmInt (-(fromInteger i))
1589 returnNat (Amode (AddrRegImm reg off) code)
1592 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1594 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1595 getRegister x `thenNat` \ register ->
1597 code = registerCode register tmp
1598 reg = registerName register tmp
1599 off = ImmInt (fromInteger i)
1601 returnNat (Amode (AddrRegImm reg off) code)
1603 getAmode (StMachOp MO_Nat_Add [x, y])
1604 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1605 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1606 getRegister x `thenNat` \ register1 ->
1607 getRegister y `thenNat` \ register2 ->
1609 code1 = registerCode register1 tmp1
1610 reg1 = registerName register1 tmp1
1611 code2 = registerCode register2 tmp2
1612 reg2 = registerName register2 tmp2
1613 code__2 = code1 `appOL` code2
1615 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1619 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1621 code = unitOL (SETHI (HI imm__2) tmp)
1623 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1626 imm__2 = case imm of Just x -> x
1629 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1630 getRegister other `thenNat` \ register ->
1632 code = registerCode register tmp
1633 reg = registerName register tmp
1636 returnNat (Amode (AddrRegImm reg off) code)
1638 #endif {- sparc_TARGET_ARCH -}
1640 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1643 %************************************************************************
1645 \subsection{The @CondCode@ type}
1647 %************************************************************************
1649 Condition codes passed up the tree.
1651 data CondCode = CondCode Bool Cond InstrBlock
1653 condName (CondCode _ cond _) = cond
1654 condFloat (CondCode is_float _ _) = is_float
1655 condCode (CondCode _ _ code) = code
1658 Set up a condition code for a conditional branch.
1661 getCondCode :: StixExpr -> NatM CondCode
1663 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1665 #if alpha_TARGET_ARCH
1666 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1667 #endif {- alpha_TARGET_ARCH -}
1669 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1671 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1672 -- yes, they really do seem to want exactly the same!
1674 getCondCode (StMachOp mop [x, y])
1676 MO_32U_Gt -> condIntCode GTT x y
1677 MO_32U_Ge -> condIntCode GE x y
1678 MO_32U_Eq -> condIntCode EQQ x y
1679 MO_32U_Ne -> condIntCode NE x y
1680 MO_32U_Lt -> condIntCode LTT x y
1681 MO_32U_Le -> condIntCode LE x y
1683 MO_Nat_Eq -> condIntCode EQQ x y
1684 MO_Nat_Ne -> condIntCode NE x y
1686 MO_NatS_Gt -> condIntCode GTT x y
1687 MO_NatS_Ge -> condIntCode GE x y
1688 MO_NatS_Lt -> condIntCode LTT x y
1689 MO_NatS_Le -> condIntCode LE x y
1691 MO_NatU_Gt -> condIntCode GU x y
1692 MO_NatU_Ge -> condIntCode GEU x y
1693 MO_NatU_Lt -> condIntCode LU x y
1694 MO_NatU_Le -> condIntCode LEU x y
1696 MO_Flt_Gt -> condFltCode GTT x y
1697 MO_Flt_Ge -> condFltCode GE x y
1698 MO_Flt_Eq -> condFltCode EQQ x y
1699 MO_Flt_Ne -> condFltCode NE x y
1700 MO_Flt_Lt -> condFltCode LTT x y
1701 MO_Flt_Le -> condFltCode LE x y
1703 MO_Dbl_Gt -> condFltCode GTT x y
1704 MO_Dbl_Ge -> condFltCode GE x y
1705 MO_Dbl_Eq -> condFltCode EQQ x y
1706 MO_Dbl_Ne -> condFltCode NE x y
1707 MO_Dbl_Lt -> condFltCode LTT x y
1708 MO_Dbl_Le -> condFltCode LE x y
1710 other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1712 getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1714 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1716 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1721 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1722 passed back up the tree.
1725 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1727 #if alpha_TARGET_ARCH
1728 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1729 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1730 #endif {- alpha_TARGET_ARCH -}
1732 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1733 #if i386_TARGET_ARCH
1735 -- memory vs immediate
1736 condIntCode cond (StInd pk x) y
1737 | Just i <- maybeImm y
1738 = getAmode x `thenNat` \ amode ->
1740 code1 = amodeCode amode
1741 x__2 = amodeAddr amode
1742 sz = primRepToSize pk
1743 code__2 = code1 `snocOL`
1744 CMP sz (OpImm i) (OpAddr x__2)
1746 returnNat (CondCode False cond code__2)
1749 condIntCode cond x (StInt 0)
1750 = getRegister x `thenNat` \ register1 ->
1751 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1753 code1 = registerCode register1 tmp1
1754 src1 = registerName register1 tmp1
1755 code__2 = code1 `snocOL`
1756 TEST L (OpReg src1) (OpReg src1)
1758 returnNat (CondCode False cond code__2)
1760 -- anything vs immediate
1761 condIntCode cond x y
1762 | Just i <- maybeImm y
1763 = getRegister x `thenNat` \ register1 ->
1764 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1766 code1 = registerCode register1 tmp1
1767 src1 = registerName register1 tmp1
1768 code__2 = code1 `snocOL`
1769 CMP L (OpImm i) (OpReg src1)
1771 returnNat (CondCode False cond code__2)
1773 -- memory vs anything
1774 condIntCode cond (StInd pk x) y
1775 = getAmode x `thenNat` \ amode_x ->
1776 getRegister y `thenNat` \ reg_y ->
1777 getNewRegNCG IntRep `thenNat` \ tmp ->
1779 c_x = amodeCode amode_x
1780 am_x = amodeAddr amode_x
1781 c_y = registerCode reg_y tmp
1782 r_y = registerName reg_y tmp
1783 sz = primRepToSize pk
1785 -- optimisation: if there's no code for x, just an amode,
1786 -- use whatever reg y winds up in. Assumes that c_y doesn't
1787 -- clobber any regs in the amode am_x, which I'm not sure is
1788 -- justified. The otherwise clause makes the same assumption.
1789 code__2 | isNilOL c_x
1791 CMP sz (OpReg r_y) (OpAddr am_x)
1795 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1797 CMP sz (OpReg tmp) (OpAddr am_x)
1799 returnNat (CondCode False cond code__2)
1801 -- anything vs memory
1803 condIntCode cond y (StInd pk x)
1804 = getAmode x `thenNat` \ amode_x ->
1805 getRegister y `thenNat` \ reg_y ->
1806 getNewRegNCG IntRep `thenNat` \ tmp ->
1808 c_x = amodeCode amode_x
1809 am_x = amodeAddr amode_x
1810 c_y = registerCode reg_y tmp
1811 r_y = registerName reg_y tmp
1812 sz = primRepToSize pk
1813 -- same optimisation and nagging doubts as previous clause
1814 code__2 | isNilOL c_x
1816 CMP sz (OpAddr am_x) (OpReg r_y)
1820 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1822 CMP sz (OpAddr am_x) (OpReg tmp)
1824 returnNat (CondCode False cond code__2)
1826 -- anything vs anything
1827 condIntCode cond x y
1828 = getRegister x `thenNat` \ register1 ->
1829 getRegister y `thenNat` \ register2 ->
1830 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1831 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1833 code1 = registerCode register1 tmp1
1834 src1 = registerName register1 tmp1
1835 code2 = registerCode register2 tmp2
1836 src2 = registerName register2 tmp2
1837 code__2 = code1 `snocOL`
1838 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1840 CMP L (OpReg src2) (OpReg tmp1)
1842 returnNat (CondCode False cond code__2)
1845 condFltCode cond x y
1846 = getRegister x `thenNat` \ register1 ->
1847 getRegister y `thenNat` \ register2 ->
1848 getNewRegNCG (registerRep register1)
1850 getNewRegNCG (registerRep register2)
1852 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1854 pk1 = registerRep register1
1855 code1 = registerCode register1 tmp1
1856 src1 = registerName register1 tmp1
1858 code2 = registerCode register2 tmp2
1859 src2 = registerName register2 tmp2
1861 code__2 | isAny register1
1862 = code1 `appOL` -- result in tmp1
1864 GCMP (primRepToSize pk1) tmp1 src2
1868 GMOV src1 tmp1 `appOL`
1870 GCMP (primRepToSize pk1) tmp1 src2
1872 {- On the 486, the flags set by FP compare are the unsigned ones!
1873 (This looks like a HACK to me. WDP 96/03)
1875 fix_FP_cond :: Cond -> Cond
1877 fix_FP_cond GE = GEU
1878 fix_FP_cond GTT = GU
1879 fix_FP_cond LTT = LU
1880 fix_FP_cond LE = LEU
1881 fix_FP_cond any = any
1883 returnNat (CondCode True (fix_FP_cond cond) code__2)
1885 #endif {- i386_TARGET_ARCH -}
1887 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1889 #if sparc_TARGET_ARCH
1891 condIntCode cond x (StInt y)
1893 = getRegister x `thenNat` \ register ->
1894 getNewRegNCG IntRep `thenNat` \ tmp ->
1896 code = registerCode register tmp
1897 src1 = registerName register tmp
1898 src2 = ImmInt (fromInteger y)
1899 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1901 returnNat (CondCode False cond code__2)
1903 condIntCode cond x y
1904 = getRegister x `thenNat` \ register1 ->
1905 getRegister y `thenNat` \ register2 ->
1906 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1907 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1909 code1 = registerCode register1 tmp1
1910 src1 = registerName register1 tmp1
1911 code2 = registerCode register2 tmp2
1912 src2 = registerName register2 tmp2
1913 code__2 = code1 `appOL` code2 `snocOL`
1914 SUB False True src1 (RIReg src2) g0
1916 returnNat (CondCode False cond code__2)
1919 condFltCode cond x y
1920 = getRegister x `thenNat` \ register1 ->
1921 getRegister y `thenNat` \ register2 ->
1922 getNewRegNCG (registerRep register1)
1924 getNewRegNCG (registerRep register2)
1926 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1928 promote x = FxTOy F DF x tmp
1930 pk1 = registerRep register1
1931 code1 = registerCode register1 tmp1
1932 src1 = registerName register1 tmp1
1934 pk2 = registerRep register2
1935 code2 = registerCode register2 tmp2
1936 src2 = registerName register2 tmp2
1940 code1 `appOL` code2 `snocOL`
1941 FCMP True (primRepToSize pk1) src1 src2
1942 else if pk1 == FloatRep then
1943 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1944 FCMP True DF tmp src2
1946 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1947 FCMP True DF src1 tmp
1949 returnNat (CondCode True cond code__2)
1951 #endif {- sparc_TARGET_ARCH -}
1953 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1956 %************************************************************************
1958 \subsection{Generating assignments}
1960 %************************************************************************
1962 Assignments are really at the heart of the whole code generation
1963 business. Almost all top-level nodes of any real importance are
1964 assignments, which correspond to loads, stores, or register transfers.
1965 If we're really lucky, some of the register transfers will go away,
1966 because we can use the destination register to complete the code
1967 generation for the right hand side. This only fails when the right
1968 hand side is forced into a fixed register (e.g. the result of a call).
1971 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1972 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
1974 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1975 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
1977 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1979 #if alpha_TARGET_ARCH
1981 assignIntCode pk (StInd _ dst) src
1982 = getNewRegNCG IntRep `thenNat` \ tmp ->
1983 getAmode dst `thenNat` \ amode ->
1984 getRegister src `thenNat` \ register ->
1986 code1 = amodeCode amode []
1987 dst__2 = amodeAddr amode
1988 code2 = registerCode register tmp []
1989 src__2 = registerName register tmp
1990 sz = primRepToSize pk
1991 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1995 assignIntCode pk dst src
1996 = getRegister dst `thenNat` \ register1 ->
1997 getRegister src `thenNat` \ register2 ->
1999 dst__2 = registerName register1 zeroh
2000 code = registerCode register2 dst__2
2001 src__2 = registerName register2 dst__2
2002 code__2 = if isFixed register2
2003 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2008 #endif {- alpha_TARGET_ARCH -}
2010 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2012 #if i386_TARGET_ARCH
2014 -- non-FP assignment to memory
2015 assignMem_IntCode pk addr src
2016 = getAmode addr `thenNat` \ amode ->
2017 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2018 getNewRegNCG PtrRep `thenNat` \ tmp ->
2020 -- In general, if the address computation for dst may require
2021 -- some insns preceding the addressing mode itself. So there's
2022 -- no guarantee that the code for dst and the code for src won't
2023 -- write the same register. This means either the address or
2024 -- the value needs to be copied into a temporary. We detect the
2025 -- common case where the amode has no code, and elide the copy.
2026 codea = amodeCode amode
2027 dst__a = amodeAddr amode
2029 code | isNilOL codea
2031 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2034 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2036 MOV (primRepToSize pk) opsrc
2037 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2043 -> NatM (InstrBlock,Operand) -- code, operator
2046 | Just x <- maybeImm op
2047 = returnNat (nilOL, OpImm x)
2050 = getRegister op `thenNat` \ register ->
2051 getNewRegNCG (registerRep register)
2053 let code = registerCode register tmp
2054 reg = registerName register tmp
2056 returnNat (code, OpReg reg)
2058 -- Assign; dst is a reg, rhs is mem
2059 assignReg_IntCode pk reg (StInd pks src)
2060 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2061 getAmode src `thenNat` \ amode ->
2062 getRegisterReg reg `thenNat` \ reg_dst ->
2064 c_addr = amodeCode amode
2065 am_addr = amodeAddr amode
2066 r_dst = registerName reg_dst tmp
2067 szs = primRepToSize pks
2076 code = c_addr `snocOL`
2077 opc (OpAddr am_addr) (OpReg r_dst)
2081 -- dst is a reg, but src could be anything
2082 assignReg_IntCode pk reg src
2083 = getRegisterReg reg `thenNat` \ registerd ->
2084 getRegister src `thenNat` \ registers ->
2085 getNewRegNCG IntRep `thenNat` \ tmp ->
2087 r_dst = registerName registerd tmp
2088 r_src = registerName registers r_dst
2089 c_src = registerCode registers r_dst
2091 code = c_src `snocOL`
2092 MOV L (OpReg r_src) (OpReg r_dst)
2096 #endif {- i386_TARGET_ARCH -}
2098 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2100 #if sparc_TARGET_ARCH
2102 assignMem_IntCode pk addr src
2103 = getNewRegNCG IntRep `thenNat` \ tmp ->
2104 getAmode addr `thenNat` \ amode ->
2105 getRegister src `thenNat` \ register ->
2107 code1 = amodeCode amode
2108 dst__2 = amodeAddr amode
2109 code2 = registerCode register tmp
2110 src__2 = registerName register tmp
2111 sz = primRepToSize pk
2112 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2116 assignReg_IntCode pk reg src
2117 = getRegister src `thenNat` \ register2 ->
2118 getRegisterReg reg `thenNat` \ register1 ->
2120 dst__2 = registerName register1 g0
2121 code = registerCode register2 dst__2
2122 src__2 = registerName register2 dst__2
2123 code__2 = if isFixed register2
2124 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2129 #endif {- sparc_TARGET_ARCH -}
2131 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2134 % --------------------------------
2135 Floating-point assignments:
2136 % --------------------------------
2139 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2140 #if alpha_TARGET_ARCH
2142 assignFltCode pk (StInd _ dst) src
2143 = getNewRegNCG pk `thenNat` \ tmp ->
2144 getAmode dst `thenNat` \ amode ->
2145 getRegister src `thenNat` \ register ->
2147 code1 = amodeCode amode []
2148 dst__2 = amodeAddr amode
2149 code2 = registerCode register tmp []
2150 src__2 = registerName register tmp
2151 sz = primRepToSize pk
2152 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2156 assignFltCode pk dst src
2157 = getRegister dst `thenNat` \ register1 ->
2158 getRegister src `thenNat` \ register2 ->
2160 dst__2 = registerName register1 zeroh
2161 code = registerCode register2 dst__2
2162 src__2 = registerName register2 dst__2
2163 code__2 = if isFixed register2
2164 then code . mkSeqInstr (FMOV src__2 dst__2)
2169 #endif {- alpha_TARGET_ARCH -}
2171 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2173 #if i386_TARGET_ARCH
2175 -- Floating point assignment to memory
2176 assignMem_FltCode pk addr src
2177 = getRegister src `thenNat` \ reg_src ->
2178 getRegister addr `thenNat` \ reg_addr ->
2179 getNewRegNCG pk `thenNat` \ tmp_src ->
2180 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2181 let r_src = registerName reg_src tmp_src
2182 c_src = registerCode reg_src tmp_src
2183 r_addr = registerName reg_addr tmp_addr
2184 c_addr = registerCode reg_addr tmp_addr
2185 sz = primRepToSize pk
2187 code = c_src `appOL`
2188 -- no need to preserve r_src across the addr computation,
2189 -- since r_src must be a float reg
2190 -- whilst r_addr is an int reg
2193 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2197 -- Floating point assignment to a register/temporary
2198 assignReg_FltCode pk reg src
2199 = getRegisterReg reg `thenNat` \ reg_dst ->
2200 getRegister src `thenNat` \ reg_src ->
2201 getNewRegNCG pk `thenNat` \ tmp ->
2203 r_dst = registerName reg_dst tmp
2204 r_src = registerName reg_src r_dst
2205 c_src = registerCode reg_src r_dst
2207 code = if isFixed reg_src
2208 then c_src `snocOL` GMOV r_src r_dst
2214 #endif {- i386_TARGET_ARCH -}
2216 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2218 #if sparc_TARGET_ARCH
2220 -- Floating point assignment to memory
2221 assignMem_FltCode pk addr src
2222 = getNewRegNCG pk `thenNat` \ tmp1 ->
2223 getAmode addr `thenNat` \ amode ->
2224 getRegister src `thenNat` \ register ->
2226 sz = primRepToSize pk
2227 dst__2 = amodeAddr amode
2229 code1 = amodeCode amode
2230 code2 = registerCode register tmp1
2232 src__2 = registerName register tmp1
2233 pk__2 = registerRep register
2234 sz__2 = primRepToSize pk__2
2236 code__2 = code1 `appOL` code2 `appOL`
2238 then unitOL (ST sz src__2 dst__2)
2239 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2243 -- Floating point assignment to a register/temporary
2244 -- Why is this so bizarrely ugly?
2245 assignReg_FltCode pk reg src
2246 = getRegisterReg reg `thenNat` \ register1 ->
2247 getRegister src `thenNat` \ register2 ->
2249 pk__2 = registerRep register2
2250 sz__2 = primRepToSize pk__2
2252 getNewRegNCG pk__2 `thenNat` \ tmp ->
2254 sz = primRepToSize pk
2255 dst__2 = registerName register1 g0 -- must be Fixed
2256 reg__2 = if pk /= pk__2 then tmp else dst__2
2257 code = registerCode register2 reg__2
2258 src__2 = registerName register2 reg__2
2261 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2262 else if isFixed register2 then
2263 code `snocOL` FMOV sz src__2 dst__2
2269 #endif {- sparc_TARGET_ARCH -}
2271 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2274 %************************************************************************
2276 \subsection{Generating an unconditional branch}
2278 %************************************************************************
2280 We accept two types of targets: an immediate CLabel or a tree that
2281 gets evaluated into a register. Any CLabels which are AsmTemporaries
2282 are assumed to be in the local block of code, close enough for a
2283 branch instruction. Other CLabels are assumed to be far away.
2285 (If applicable) Do not fill the delay slots here; you will confuse the
2289 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2291 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2293 #if alpha_TARGET_ARCH
2295 genJump (StCLbl lbl)
2296 | isAsmTemp lbl = returnInstr (BR target)
2297 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2299 target = ImmCLbl lbl
2302 = getRegister tree `thenNat` \ register ->
2303 getNewRegNCG PtrRep `thenNat` \ tmp ->
2305 dst = registerName register pv
2306 code = registerCode register pv
2307 target = registerName register pv
2309 if isFixed register then
2310 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2312 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2314 #endif {- alpha_TARGET_ARCH -}
2316 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2318 #if i386_TARGET_ARCH
2320 genJump dsts (StInd pk mem)
2321 = getAmode mem `thenNat` \ amode ->
2323 code = amodeCode amode
2324 target = amodeAddr amode
2326 returnNat (code `snocOL` JMP dsts (OpAddr target))
2330 = returnNat (unitOL (JMP dsts (OpImm target)))
2333 = getRegister tree `thenNat` \ register ->
2334 getNewRegNCG PtrRep `thenNat` \ tmp ->
2336 code = registerCode register tmp
2337 target = registerName register tmp
2339 returnNat (code `snocOL` JMP dsts (OpReg target))
2342 target = case imm of Just x -> x
2344 #endif {- i386_TARGET_ARCH -}
2346 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2348 #if sparc_TARGET_ARCH
2350 genJump dsts (StCLbl lbl)
2351 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2352 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2353 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2355 target = ImmCLbl lbl
2358 = getRegister tree `thenNat` \ register ->
2359 getNewRegNCG PtrRep `thenNat` \ tmp ->
2361 code = registerCode register tmp
2362 target = registerName register tmp
2364 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2366 #endif {- sparc_TARGET_ARCH -}
2368 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2371 %************************************************************************
2373 \subsection{Conditional jumps}
2375 %************************************************************************
2377 Conditional jumps are always to local labels, so we can use branch
2378 instructions. We peek at the arguments to decide what kind of
2381 ALPHA: For comparisons with 0, we're laughing, because we can just do
2382 the desired conditional branch.
2384 I386: First, we have to ensure that the condition
2385 codes are set according to the supplied comparison operation.
2387 SPARC: First, we have to ensure that the condition codes are set
2388 according to the supplied comparison operation. We generate slightly
2389 different code for floating point comparisons, because a floating
2390 point operation cannot directly precede a @BF@. We assume the worst
2391 and fill that slot with a @NOP@.
2393 SPARC: Do not fill the delay slots here; you will confuse the register
2398 :: CLabel -- the branch target
2399 -> StixExpr -- the condition on which to branch
2402 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2404 #if alpha_TARGET_ARCH
2406 genCondJump lbl (StPrim op [x, StInt 0])
2407 = getRegister x `thenNat` \ register ->
2408 getNewRegNCG (registerRep register)
2411 code = registerCode register tmp
2412 value = registerName register tmp
2413 pk = registerRep register
2414 target = ImmCLbl lbl
2416 returnSeq code [BI (cmpOp op) value target]
2418 cmpOp CharGtOp = GTT
2420 cmpOp CharEqOp = EQQ
2422 cmpOp CharLtOp = LTT
2431 cmpOp WordGeOp = ALWAYS
2432 cmpOp WordEqOp = EQQ
2434 cmpOp WordLtOp = NEVER
2435 cmpOp WordLeOp = EQQ
2437 cmpOp AddrGeOp = ALWAYS
2438 cmpOp AddrEqOp = EQQ
2440 cmpOp AddrLtOp = NEVER
2441 cmpOp AddrLeOp = EQQ
2443 genCondJump lbl (StPrim op [x, StDouble 0.0])
2444 = getRegister x `thenNat` \ register ->
2445 getNewRegNCG (registerRep register)
2448 code = registerCode register tmp
2449 value = registerName register tmp
2450 pk = registerRep register
2451 target = ImmCLbl lbl
2453 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2455 cmpOp FloatGtOp = GTT
2456 cmpOp FloatGeOp = GE
2457 cmpOp FloatEqOp = EQQ
2458 cmpOp FloatNeOp = NE
2459 cmpOp FloatLtOp = LTT
2460 cmpOp FloatLeOp = LE
2461 cmpOp DoubleGtOp = GTT
2462 cmpOp DoubleGeOp = GE
2463 cmpOp DoubleEqOp = EQQ
2464 cmpOp DoubleNeOp = NE
2465 cmpOp DoubleLtOp = LTT
2466 cmpOp DoubleLeOp = LE
2468 genCondJump lbl (StPrim op [x, y])
2470 = trivialFCode pr instr x y `thenNat` \ register ->
2471 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2473 code = registerCode register tmp
2474 result = registerName register tmp
2475 target = ImmCLbl lbl
2477 returnNat (code . mkSeqInstr (BF cond result target))
2479 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2481 fltCmpOp op = case op of
2495 (instr, cond) = case op of
2496 FloatGtOp -> (FCMP TF LE, EQQ)
2497 FloatGeOp -> (FCMP TF LTT, EQQ)
2498 FloatEqOp -> (FCMP TF EQQ, NE)
2499 FloatNeOp -> (FCMP TF EQQ, EQQ)
2500 FloatLtOp -> (FCMP TF LTT, NE)
2501 FloatLeOp -> (FCMP TF LE, NE)
2502 DoubleGtOp -> (FCMP TF LE, EQQ)
2503 DoubleGeOp -> (FCMP TF LTT, EQQ)
2504 DoubleEqOp -> (FCMP TF EQQ, NE)
2505 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2506 DoubleLtOp -> (FCMP TF LTT, NE)
2507 DoubleLeOp -> (FCMP TF LE, NE)
2509 genCondJump lbl (StPrim op [x, y])
2510 = trivialCode instr x y `thenNat` \ register ->
2511 getNewRegNCG IntRep `thenNat` \ tmp ->
2513 code = registerCode register tmp
2514 result = registerName register tmp
2515 target = ImmCLbl lbl
2517 returnNat (code . mkSeqInstr (BI cond result target))
2519 (instr, cond) = case op of
2520 CharGtOp -> (CMP LE, EQQ)
2521 CharGeOp -> (CMP LTT, EQQ)
2522 CharEqOp -> (CMP EQQ, NE)
2523 CharNeOp -> (CMP EQQ, EQQ)
2524 CharLtOp -> (CMP LTT, NE)
2525 CharLeOp -> (CMP LE, NE)
2526 IntGtOp -> (CMP LE, EQQ)
2527 IntGeOp -> (CMP LTT, EQQ)
2528 IntEqOp -> (CMP EQQ, NE)
2529 IntNeOp -> (CMP EQQ, EQQ)
2530 IntLtOp -> (CMP LTT, NE)
2531 IntLeOp -> (CMP LE, NE)
2532 WordGtOp -> (CMP ULE, EQQ)
2533 WordGeOp -> (CMP ULT, EQQ)
2534 WordEqOp -> (CMP EQQ, NE)
2535 WordNeOp -> (CMP EQQ, EQQ)
2536 WordLtOp -> (CMP ULT, NE)
2537 WordLeOp -> (CMP ULE, NE)
2538 AddrGtOp -> (CMP ULE, EQQ)
2539 AddrGeOp -> (CMP ULT, EQQ)
2540 AddrEqOp -> (CMP EQQ, NE)
2541 AddrNeOp -> (CMP EQQ, EQQ)
2542 AddrLtOp -> (CMP ULT, NE)
2543 AddrLeOp -> (CMP ULE, NE)
2545 #endif {- alpha_TARGET_ARCH -}
2547 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2549 #if i386_TARGET_ARCH
2551 genCondJump lbl bool
2552 = getCondCode bool `thenNat` \ condition ->
2554 code = condCode condition
2555 cond = condName condition
2557 returnNat (code `snocOL` JXX cond lbl)
2559 #endif {- i386_TARGET_ARCH -}
2561 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2563 #if sparc_TARGET_ARCH
2565 genCondJump lbl bool
2566 = getCondCode bool `thenNat` \ condition ->
2568 code = condCode condition
2569 cond = condName condition
2570 target = ImmCLbl lbl
2575 if condFloat condition
2576 then [NOP, BF cond False target, NOP]
2577 else [BI cond False target, NOP]
2581 #endif {- sparc_TARGET_ARCH -}
2583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2586 %************************************************************************
2588 \subsection{Generating C calls}
2590 %************************************************************************
2592 Now the biggest nightmare---calls. Most of the nastiness is buried in
2593 @get_arg@, which moves the arguments to the correct registers/stack
2594 locations. Apart from that, the code is easy.
2596 (If applicable) Do not fill the delay slots here; you will confuse the
2601 :: FAST_STRING -- function to call
2603 -> PrimRep -- type of the result
2604 -> [StixExpr] -- arguments (of mixed type)
2607 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2609 #if alpha_TARGET_ARCH
2611 genCCall fn cconv kind args
2612 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2613 `thenNat` \ ((unused,_), argCode) ->
2615 nRegs = length allArgRegs - length unused
2616 code = asmSeqThen (map ($ []) argCode)
2619 LDA pv (AddrImm (ImmLab (ptext fn))),
2620 JSR ra (AddrReg pv) nRegs,
2621 LDGP gp (AddrReg ra)]
2623 ------------------------
2624 {- Try to get a value into a specific register (or registers) for
2625 a call. The first 6 arguments go into the appropriate
2626 argument register (separate registers for integer and floating
2627 point arguments, but used in lock-step), and the remaining
2628 arguments are dumped to the stack, beginning at 0(sp). Our
2629 first argument is a pair of the list of remaining argument
2630 registers to be assigned for this call and the next stack
2631 offset to use for overflowing arguments. This way,
2632 @get_Arg@ can be applied to all of a call's arguments using
2636 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2637 -> StixTree -- Current argument
2638 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2640 -- We have to use up all of our argument registers first...
2642 get_arg ((iDst,fDst):dsts, offset) arg
2643 = getRegister arg `thenNat` \ register ->
2645 reg = if isFloatingRep pk then fDst else iDst
2646 code = registerCode register reg
2647 src = registerName register reg
2648 pk = registerRep register
2651 if isFloatingRep pk then
2652 ((dsts, offset), if isFixed register then
2653 code . mkSeqInstr (FMOV src fDst)
2656 ((dsts, offset), if isFixed register then
2657 code . mkSeqInstr (OR src (RIReg src) iDst)
2660 -- Once we have run out of argument registers, we move to the
2663 get_arg ([], offset) arg
2664 = getRegister arg `thenNat` \ register ->
2665 getNewRegNCG (registerRep register)
2668 code = registerCode register tmp
2669 src = registerName register tmp
2670 pk = registerRep register
2671 sz = primRepToSize pk
2673 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2675 #endif {- alpha_TARGET_ARCH -}
2677 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2679 #if i386_TARGET_ARCH
2681 genCCall fn cconv ret_rep [StInt i]
2682 | fn == SLIT ("PerformGC_wrapper")
2684 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2685 CALL (ImmLit (ptext (if underscorePrefix
2686 then (SLIT ("_PerformGC_wrapper"))
2687 else (SLIT ("PerformGC_wrapper")))))
2693 genCCall fn cconv ret_rep args
2695 (reverse args) `thenNat` \ sizes_n_codes ->
2696 getDeltaNat `thenNat` \ delta ->
2697 let (sizes, codes) = unzip sizes_n_codes
2698 tot_arg_size = sum sizes
2699 code2 = concatOL codes
2701 [CALL (fn__2 tot_arg_size)]
2703 -- Deallocate parameters after call for ccall;
2704 -- but not for stdcall (callee does it)
2705 (if cconv == StdCallConv then [] else
2706 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2709 [DELTA (delta + tot_arg_size)]
2712 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2713 returnNat (code2 `appOL` call)
2716 -- function names that begin with '.' are assumed to be special
2717 -- internally generated names like '.mul,' which don't get an
2718 -- underscore prefix
2719 -- ToDo:needed (WDP 96/03) ???
2723 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2724 | otherwise -- General case
2725 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2727 stdcallsize tot_arg_size
2728 | cconv == StdCallConv = '@':show tot_arg_size
2736 push_arg :: StixExpr{-current argument-}
2737 -> NatM (Int, InstrBlock) -- argsz, code
2740 | is64BitRep arg_rep
2741 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2742 getDeltaNat `thenNat` \ delta ->
2743 setDeltaNat (delta - 8) `thenNat` \ _ ->
2744 let r_lo = VirtualRegI vr_lo
2745 r_hi = getHiVRegFromLo r_lo
2748 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2749 PUSH L (OpReg r_lo), DELTA (delta - 8)]
2752 = get_op arg `thenNat` \ (code, reg, sz) ->
2753 getDeltaNat `thenNat` \ delta ->
2754 arg_size sz `bind` \ size ->
2755 setDeltaNat (delta-size) `thenNat` \ _ ->
2756 if (case sz of DF -> True; F -> True; _ -> False)
2757 then returnNat (size,
2759 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2761 GST sz reg (AddrBaseIndex (Just esp)
2765 else returnNat (size,
2767 PUSH L (OpReg reg) `snocOL`
2771 arg_rep = repOfStixExpr arg
2776 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2779 = getRegister op `thenNat` \ register ->
2780 getNewRegNCG (registerRep register)
2783 code = registerCode register tmp
2784 reg = registerName register tmp
2785 pk = registerRep register
2786 sz = primRepToSize pk
2788 returnNat (code, reg, sz)
2790 #endif {- i386_TARGET_ARCH -}
2792 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2794 #if sparc_TARGET_ARCH
2796 The SPARC calling convention is an absolute
2797 nightmare. The first 6x32 bits of arguments are mapped into
2798 %o0 through %o5, and the remaining arguments are dumped to the
2799 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2801 If we have to put args on the stack, move %o6==%sp down by
2802 the number of words to go on the stack, to ensure there's enough space.
2804 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2805 16 words above the stack pointer is a word for the address of
2806 a structure return value. I use this as a temporary location
2807 for moving values from float to int regs. Certainly it isn't
2808 safe to put anything in the 16 words starting at %sp, since
2809 this area can get trashed at any time due to window overflows
2810 caused by signal handlers.
2812 A final complication (if the above isn't enough) is that
2813 we can't blithely calculate the arguments one by one into
2814 %o0 .. %o5. Consider the following nested calls:
2818 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2819 the inner call will itself use %o0, which trashes the value put there
2820 in preparation for the outer call. Upshot: we need to calculate the
2821 args into temporary regs, and move those to arg regs or onto the
2822 stack only immediately prior to the call proper. Sigh.
2825 genCCall fn cconv kind args
2826 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2827 let (argcodes, vregss) = unzip argcode_and_vregs
2828 argcode = concatOL argcodes
2829 vregs = concat vregss
2830 n_argRegs = length allArgRegs
2831 n_argRegs_used = min (length vregs) n_argRegs
2832 (move_sp_down, move_sp_up)
2833 = let nn = length vregs - n_argRegs
2834 + 1 -- (for the road)
2837 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2839 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2841 = unitOL (CALL fn__2 n_argRegs_used False)
2843 returnNat (argcode `appOL`
2844 move_sp_down `appOL`
2845 transfer_code `appOL`
2850 -- function names that begin with '.' are assumed to be special
2851 -- internally generated names like '.mul,' which don't get an
2852 -- underscore prefix
2853 -- ToDo:needed (WDP 96/03) ???
2854 fn__2 = case (_HEAD_ fn) of
2855 '.' -> ImmLit (ptext fn)
2856 _ -> ImmLab False (ptext fn)
2858 -- move args from the integer vregs into which they have been
2859 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2860 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2862 move_final [] _ offset -- all args done
2865 move_final (v:vs) [] offset -- out of aregs; move to stack
2866 = ST W v (spRel offset)
2867 : move_final vs [] (offset+1)
2869 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2870 = OR False g0 (RIReg v) a
2871 : move_final vs az offset
2873 -- generate code to calculate an argument, and move it into one
2874 -- or two integer vregs.
2875 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2876 arg_to_int_vregs arg
2877 | is64BitRep (repOfStixExpr arg)
2878 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
2879 let r_lo = VirtualRegI vr_lo
2880 r_hi = getHiVRegFromLo r_lo
2881 in returnNat (code, [r_hi, r_lo])
2883 = getRegister arg `thenNat` \ register ->
2884 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2885 let code = registerCode register tmp
2886 src = registerName register tmp
2887 pk = registerRep register
2889 -- the value is in src. Get it into 1 or 2 int vregs.
2892 getNewRegNCG WordRep `thenNat` \ v1 ->
2893 getNewRegNCG WordRep `thenNat` \ v2 ->
2896 FMOV DF src f0 `snocOL`
2897 ST F f0 (spRel 16) `snocOL`
2898 LD W (spRel 16) v1 `snocOL`
2899 ST F (fPair f0) (spRel 16) `snocOL`
2905 getNewRegNCG WordRep `thenNat` \ v1 ->
2908 ST F src (spRel 16) `snocOL`
2914 getNewRegNCG WordRep `thenNat` \ v1 ->
2916 code `snocOL` OR False g0 (RIReg src) v1
2920 #endif {- sparc_TARGET_ARCH -}
2922 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2925 %************************************************************************
2927 \subsection{Support bits}
2929 %************************************************************************
2931 %************************************************************************
2933 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2935 %************************************************************************
2937 Turn those condition codes into integers now (when they appear on
2938 the right hand side of an assignment).
2940 (If applicable) Do not fill the delay slots here; you will confuse the
2944 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2946 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2948 #if alpha_TARGET_ARCH
2949 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2950 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2951 #endif {- alpha_TARGET_ARCH -}
2953 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2955 #if i386_TARGET_ARCH
2958 = condIntCode cond x y `thenNat` \ condition ->
2959 getNewRegNCG IntRep `thenNat` \ tmp ->
2961 code = condCode condition
2962 cond = condName condition
2963 code__2 dst = code `appOL` toOL [
2964 SETCC cond (OpReg tmp),
2965 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2966 MOV L (OpReg tmp) (OpReg dst)]
2968 returnNat (Any IntRep code__2)
2971 = getNatLabelNCG `thenNat` \ lbl1 ->
2972 getNatLabelNCG `thenNat` \ lbl2 ->
2973 condFltCode cond x y `thenNat` \ condition ->
2975 code = condCode condition
2976 cond = condName condition
2977 code__2 dst = code `appOL` toOL [
2979 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2982 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2985 returnNat (Any IntRep code__2)
2987 #endif {- i386_TARGET_ARCH -}
2989 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2991 #if sparc_TARGET_ARCH
2993 condIntReg EQQ x (StInt 0)
2994 = getRegister x `thenNat` \ register ->
2995 getNewRegNCG IntRep `thenNat` \ tmp ->
2997 code = registerCode register tmp
2998 src = registerName register tmp
2999 code__2 dst = code `appOL` toOL [
3000 SUB False True g0 (RIReg src) g0,
3001 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3003 returnNat (Any IntRep code__2)
3006 = getRegister x `thenNat` \ register1 ->
3007 getRegister y `thenNat` \ register2 ->
3008 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3009 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3011 code1 = registerCode register1 tmp1
3012 src1 = registerName register1 tmp1
3013 code2 = registerCode register2 tmp2
3014 src2 = registerName register2 tmp2
3015 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3016 XOR False src1 (RIReg src2) dst,
3017 SUB False True g0 (RIReg dst) g0,
3018 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3020 returnNat (Any IntRep code__2)
3022 condIntReg NE x (StInt 0)
3023 = getRegister x `thenNat` \ register ->
3024 getNewRegNCG IntRep `thenNat` \ tmp ->
3026 code = registerCode register tmp
3027 src = registerName register tmp
3028 code__2 dst = code `appOL` toOL [
3029 SUB False True g0 (RIReg src) g0,
3030 ADD True False g0 (RIImm (ImmInt 0)) dst]
3032 returnNat (Any IntRep code__2)
3035 = getRegister x `thenNat` \ register1 ->
3036 getRegister y `thenNat` \ register2 ->
3037 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3038 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3040 code1 = registerCode register1 tmp1
3041 src1 = registerName register1 tmp1
3042 code2 = registerCode register2 tmp2
3043 src2 = registerName register2 tmp2
3044 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3045 XOR False src1 (RIReg src2) dst,
3046 SUB False True g0 (RIReg dst) g0,
3047 ADD True False g0 (RIImm (ImmInt 0)) dst]
3049 returnNat (Any IntRep code__2)
3052 = getNatLabelNCG `thenNat` \ lbl1 ->
3053 getNatLabelNCG `thenNat` \ lbl2 ->
3054 condIntCode cond x y `thenNat` \ condition ->
3056 code = condCode condition
3057 cond = condName condition
3058 code__2 dst = code `appOL` toOL [
3059 BI cond False (ImmCLbl lbl1), NOP,
3060 OR False g0 (RIImm (ImmInt 0)) dst,
3061 BI ALWAYS False (ImmCLbl lbl2), NOP,
3063 OR False g0 (RIImm (ImmInt 1)) dst,
3066 returnNat (Any IntRep code__2)
3069 = getNatLabelNCG `thenNat` \ lbl1 ->
3070 getNatLabelNCG `thenNat` \ lbl2 ->
3071 condFltCode cond x y `thenNat` \ condition ->
3073 code = condCode condition
3074 cond = condName condition
3075 code__2 dst = code `appOL` toOL [
3077 BF cond False (ImmCLbl lbl1), NOP,
3078 OR False g0 (RIImm (ImmInt 0)) dst,
3079 BI ALWAYS False (ImmCLbl lbl2), NOP,
3081 OR False g0 (RIImm (ImmInt 1)) dst,
3084 returnNat (Any IntRep code__2)
3086 #endif {- sparc_TARGET_ARCH -}
3088 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3091 %************************************************************************
3093 \subsubsection{@trivial*Code@: deal with trivial instructions}
3095 %************************************************************************
3097 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3098 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3099 for constants on the right hand side, because that's where the generic
3100 optimizer will have put them.
3102 Similarly, for unary instructions, we don't have to worry about
3103 matching an StInt as the argument, because genericOpt will already
3104 have handled the constant-folding.
3108 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3109 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3110 -> Maybe (Operand -> Operand -> Instr)
3111 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3113 -> StixExpr -> StixExpr -- the two arguments
3118 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3119 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3120 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3122 -> StixExpr -> StixExpr -- the two arguments
3126 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3127 ,IF_ARCH_i386 ((Operand -> Instr)
3128 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3130 -> StixExpr -- the one argument
3135 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3136 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3137 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3139 -> StixExpr -- the one argument
3142 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3144 #if alpha_TARGET_ARCH
3146 trivialCode instr x (StInt y)
3148 = getRegister x `thenNat` \ register ->
3149 getNewRegNCG IntRep `thenNat` \ tmp ->
3151 code = registerCode register tmp
3152 src1 = registerName register tmp
3153 src2 = ImmInt (fromInteger y)
3154 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3156 returnNat (Any IntRep code__2)
3158 trivialCode instr x y
3159 = getRegister x `thenNat` \ register1 ->
3160 getRegister y `thenNat` \ register2 ->
3161 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3162 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3164 code1 = registerCode register1 tmp1 []
3165 src1 = registerName register1 tmp1
3166 code2 = registerCode register2 tmp2 []
3167 src2 = registerName register2 tmp2
3168 code__2 dst = asmSeqThen [code1, code2] .
3169 mkSeqInstr (instr src1 (RIReg src2) dst)
3171 returnNat (Any IntRep code__2)
3174 trivialUCode instr x
3175 = getRegister x `thenNat` \ register ->
3176 getNewRegNCG IntRep `thenNat` \ tmp ->
3178 code = registerCode register tmp
3179 src = registerName register tmp
3180 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3182 returnNat (Any IntRep code__2)
3185 trivialFCode _ instr x y
3186 = getRegister x `thenNat` \ register1 ->
3187 getRegister y `thenNat` \ register2 ->
3188 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3189 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3191 code1 = registerCode register1 tmp1
3192 src1 = registerName register1 tmp1
3194 code2 = registerCode register2 tmp2
3195 src2 = registerName register2 tmp2
3197 code__2 dst = asmSeqThen [code1 [], code2 []] .
3198 mkSeqInstr (instr src1 src2 dst)
3200 returnNat (Any DoubleRep code__2)
3202 trivialUFCode _ instr x
3203 = getRegister x `thenNat` \ register ->
3204 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3206 code = registerCode register tmp
3207 src = registerName register tmp
3208 code__2 dst = code . mkSeqInstr (instr src dst)
3210 returnNat (Any DoubleRep code__2)
3212 #endif {- alpha_TARGET_ARCH -}
3214 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3216 #if i386_TARGET_ARCH
3218 The Rules of the Game are:
3220 * You cannot assume anything about the destination register dst;
3221 it may be anything, including a fixed reg.
3223 * You may compute an operand into a fixed reg, but you may not
3224 subsequently change the contents of that fixed reg. If you
3225 want to do so, first copy the value either to a temporary
3226 or into dst. You are free to modify dst even if it happens
3227 to be a fixed reg -- that's not your problem.
3229 * You cannot assume that a fixed reg will stay live over an
3230 arbitrary computation. The same applies to the dst reg.
3232 * Temporary regs obtained from getNewRegNCG are distinct from
3233 each other and from all other regs, and stay live over
3234 arbitrary computations.
3238 trivialCode instr maybe_revinstr a b
3241 = getRegister a `thenNat` \ rega ->
3244 then registerCode rega dst `bind` \ code_a ->
3246 instr (OpImm imm_b) (OpReg dst)
3247 else registerCodeF rega `bind` \ code_a ->
3248 registerNameF rega `bind` \ r_a ->
3250 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3251 instr (OpImm imm_b) (OpReg dst)
3253 returnNat (Any IntRep mkcode)
3256 = getRegister b `thenNat` \ regb ->
3257 getNewRegNCG IntRep `thenNat` \ tmp ->
3258 let revinstr_avail = maybeToBool maybe_revinstr
3259 revinstr = case maybe_revinstr of Just ri -> ri
3263 then registerCode regb dst `bind` \ code_b ->
3265 revinstr (OpImm imm_a) (OpReg dst)
3266 else registerCodeF regb `bind` \ code_b ->
3267 registerNameF regb `bind` \ r_b ->
3269 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3270 revinstr (OpImm imm_a) (OpReg dst)
3274 then registerCode regb tmp `bind` \ code_b ->
3276 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3277 instr (OpReg tmp) (OpReg dst)
3278 else registerCodeF regb `bind` \ code_b ->
3279 registerNameF regb `bind` \ r_b ->
3281 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3282 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3283 instr (OpReg tmp) (OpReg dst)
3285 returnNat (Any IntRep mkcode)
3288 = getRegister a `thenNat` \ rega ->
3289 getRegister b `thenNat` \ regb ->
3290 getNewRegNCG IntRep `thenNat` \ tmp ->
3292 = case (isAny rega, isAny regb) of
3294 -> registerCode regb tmp `bind` \ code_b ->
3295 registerCode rega dst `bind` \ code_a ->
3298 instr (OpReg tmp) (OpReg dst)
3300 -> registerCode rega tmp `bind` \ code_a ->
3301 registerCodeF regb `bind` \ code_b ->
3302 registerNameF regb `bind` \ r_b ->
3305 instr (OpReg r_b) (OpReg tmp) `snocOL`
3306 MOV L (OpReg tmp) (OpReg dst)
3308 -> registerCode regb tmp `bind` \ code_b ->
3309 registerCodeF rega `bind` \ code_a ->
3310 registerNameF rega `bind` \ r_a ->
3313 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3314 instr (OpReg tmp) (OpReg dst)
3316 -> registerCodeF rega `bind` \ code_a ->
3317 registerNameF rega `bind` \ r_a ->
3318 registerCodeF regb `bind` \ code_b ->
3319 registerNameF regb `bind` \ r_b ->
3321 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3323 instr (OpReg r_b) (OpReg tmp) `snocOL`
3324 MOV L (OpReg tmp) (OpReg dst)
3326 returnNat (Any IntRep mkcode)
3329 maybe_imm_a = maybeImm a
3330 is_imm_a = maybeToBool maybe_imm_a
3331 imm_a = case maybe_imm_a of Just imm -> imm
3333 maybe_imm_b = maybeImm b
3334 is_imm_b = maybeToBool maybe_imm_b
3335 imm_b = case maybe_imm_b of Just imm -> imm
3339 trivialUCode instr x
3340 = getRegister x `thenNat` \ register ->
3342 code__2 dst = let code = registerCode register dst
3343 src = registerName register dst
3345 if isFixed register && dst /= src
3346 then toOL [MOV L (OpReg src) (OpReg dst),
3348 else unitOL (instr (OpReg src))
3350 returnNat (Any IntRep code__2)
3353 trivialFCode pk instr x y
3354 = getRegister x `thenNat` \ register1 ->
3355 getRegister y `thenNat` \ register2 ->
3356 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3357 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3359 code1 = registerCode register1 tmp1
3360 src1 = registerName register1 tmp1
3362 code2 = registerCode register2 tmp2
3363 src2 = registerName register2 tmp2
3366 -- treat the common case specially: both operands in
3368 | isAny register1 && isAny register2
3371 instr (primRepToSize pk) src1 src2 dst
3373 -- be paranoid (and inefficient)
3375 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3377 instr (primRepToSize pk) tmp1 src2 dst
3379 returnNat (Any pk code__2)
3383 trivialUFCode pk instr x
3384 = getRegister x `thenNat` \ register ->
3385 getNewRegNCG pk `thenNat` \ tmp ->
3387 code = registerCode register tmp
3388 src = registerName register tmp
3389 code__2 dst = code `snocOL` instr src dst
3391 returnNat (Any pk code__2)
3393 #endif {- i386_TARGET_ARCH -}
3395 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3397 #if sparc_TARGET_ARCH
3399 trivialCode instr x (StInt y)
3401 = getRegister x `thenNat` \ register ->
3402 getNewRegNCG IntRep `thenNat` \ tmp ->
3404 code = registerCode register tmp
3405 src1 = registerName register tmp
3406 src2 = ImmInt (fromInteger y)
3407 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3409 returnNat (Any IntRep code__2)
3411 trivialCode instr x y
3412 = getRegister x `thenNat` \ register1 ->
3413 getRegister y `thenNat` \ register2 ->
3414 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3415 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3417 code1 = registerCode register1 tmp1
3418 src1 = registerName register1 tmp1
3419 code2 = registerCode register2 tmp2
3420 src2 = registerName register2 tmp2
3421 code__2 dst = code1 `appOL` code2 `snocOL`
3422 instr src1 (RIReg src2) dst
3424 returnNat (Any IntRep code__2)
3427 trivialFCode pk instr x y
3428 = getRegister x `thenNat` \ register1 ->
3429 getRegister y `thenNat` \ register2 ->
3430 getNewRegNCG (registerRep register1)
3432 getNewRegNCG (registerRep register2)
3434 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3436 promote x = FxTOy F DF x tmp
3438 pk1 = registerRep register1
3439 code1 = registerCode register1 tmp1
3440 src1 = registerName register1 tmp1
3442 pk2 = registerRep register2
3443 code2 = registerCode register2 tmp2
3444 src2 = registerName register2 tmp2
3448 code1 `appOL` code2 `snocOL`
3449 instr (primRepToSize pk) src1 src2 dst
3450 else if pk1 == FloatRep then
3451 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3452 instr DF tmp src2 dst
3454 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3455 instr DF src1 tmp dst
3457 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3460 trivialUCode instr x
3461 = getRegister x `thenNat` \ register ->
3462 getNewRegNCG IntRep `thenNat` \ tmp ->
3464 code = registerCode register tmp
3465 src = registerName register tmp
3466 code__2 dst = code `snocOL` instr (RIReg src) dst
3468 returnNat (Any IntRep code__2)
3471 trivialUFCode pk instr x
3472 = getRegister x `thenNat` \ register ->
3473 getNewRegNCG pk `thenNat` \ tmp ->
3475 code = registerCode register tmp
3476 src = registerName register tmp
3477 code__2 dst = code `snocOL` instr src dst
3479 returnNat (Any pk code__2)
3481 #endif {- sparc_TARGET_ARCH -}
3483 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3486 %************************************************************************
3488 \subsubsection{Coercing to/from integer/floating-point...}
3490 %************************************************************************
3492 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3493 conversions. We have to store temporaries in memory to move
3494 between the integer and the floating point register sets.
3496 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3497 pretend, on sparc at least, that double and float regs are seperate
3498 kinds, so the value has to be computed into one kind before being
3499 explicitly "converted" to live in the other kind.
3502 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3503 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3505 coerceDbl2Flt :: StixExpr -> NatM Register
3506 coerceFlt2Dbl :: StixExpr -> NatM Register
3510 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3512 #if alpha_TARGET_ARCH
3515 = getRegister x `thenNat` \ register ->
3516 getNewRegNCG IntRep `thenNat` \ reg ->
3518 code = registerCode register reg
3519 src = registerName register reg
3521 code__2 dst = code . mkSeqInstrs [
3523 LD TF dst (spRel 0),
3526 returnNat (Any DoubleRep code__2)
3530 = getRegister x `thenNat` \ register ->
3531 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3533 code = registerCode register tmp
3534 src = registerName register tmp
3536 code__2 dst = code . mkSeqInstrs [
3538 ST TF tmp (spRel 0),
3541 returnNat (Any IntRep code__2)
3543 #endif {- alpha_TARGET_ARCH -}
3545 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3547 #if i386_TARGET_ARCH
3550 = getRegister x `thenNat` \ register ->
3551 getNewRegNCG IntRep `thenNat` \ reg ->
3553 code = registerCode register reg
3554 src = registerName register reg
3555 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3556 code__2 dst = code `snocOL` opc src dst
3558 returnNat (Any pk code__2)
3561 coerceFP2Int fprep x
3562 = getRegister x `thenNat` \ register ->
3563 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3565 code = registerCode register tmp
3566 src = registerName register tmp
3567 pk = registerRep register
3569 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3570 code__2 dst = code `snocOL` opc src dst
3572 returnNat (Any IntRep code__2)
3575 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3576 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3578 #endif {- i386_TARGET_ARCH -}
3580 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3582 #if sparc_TARGET_ARCH
3585 = getRegister x `thenNat` \ register ->
3586 getNewRegNCG IntRep `thenNat` \ reg ->
3588 code = registerCode register reg
3589 src = registerName register reg
3591 code__2 dst = code `appOL` toOL [
3592 ST W src (spRel (-2)),
3593 LD W (spRel (-2)) dst,
3594 FxTOy W (primRepToSize pk) dst dst]
3596 returnNat (Any pk code__2)
3599 coerceFP2Int fprep x
3600 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3601 getRegister x `thenNat` \ register ->
3602 getNewRegNCG fprep `thenNat` \ reg ->
3603 getNewRegNCG FloatRep `thenNat` \ tmp ->
3605 code = registerCode register reg
3606 src = registerName register reg
3607 code__2 dst = code `appOL` toOL [
3608 FxTOy (primRepToSize fprep) W src tmp,
3609 ST W tmp (spRel (-2)),
3610 LD W (spRel (-2)) dst]
3612 returnNat (Any IntRep code__2)
3616 = getRegister x `thenNat` \ register ->
3617 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3618 let code = registerCode register tmp
3619 src = registerName register tmp
3621 returnNat (Any FloatRep
3622 (\dst -> code `snocOL` FxTOy DF F src dst))
3626 = getRegister x `thenNat` \ register ->
3627 getNewRegNCG FloatRep `thenNat` \ tmp ->
3628 let code = registerCode register tmp
3629 src = registerName register tmp
3631 returnNat (Any DoubleRep
3632 (\dst -> code `snocOL` FxTOy F DF src dst))
3634 #endif {- sparc_TARGET_ARCH -}
3636 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -