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 #if powerpc_TARGET_ARCH
35 getPrimRepSizeInBytes )
36 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
37 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
38 DestInfo, hasDestInfo,
39 pprStixExpr, repOfStixExpr,
41 NatM, thenNat, returnNat, mapNat,
42 mapAndUnzipNat, mapAccumLNat,
43 getDeltaNat, setDeltaNat, getUniqueNat,
44 IF_OS_darwin(addImportNat COMMA,)
49 import Outputable ( panic, pprPanic, showSDoc )
50 import qualified Outputable
51 import CmdLineOpts ( opt_Static )
52 import Stix ( pprStixStmt )
55 import Outputable ( assertPanic )
57 import TRACE ( trace )
62 @InstrBlock@s are the insn sequences generated by the insn selectors.
63 They are really trees of insns to facilitate fast appending, where a
64 left-to-right traversal (pre-order?) yields the insns in the correct
68 type InstrBlock = OrdList Instr
72 isLeft (Left _) = True
73 isLeft (Right _) = False
78 Code extractor for an entire stix tree---stix statement level.
81 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
83 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
84 returnNat (concatOL instrss)
87 stmtToInstrs :: StixStmt -> NatM InstrBlock
88 stmtToInstrs stmt = case stmt of
89 StComment s -> returnNat (unitOL (COMMENT s))
90 StSegment seg -> returnNat (unitOL (SEGMENT seg))
92 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
94 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
97 StLabel lab -> returnNat (unitOL (LABEL lab))
99 StJump dsts arg -> genJump dsts (derefDLL arg)
100 StCondJump lab arg -> genCondJump lab (derefDLL arg)
102 -- A call returning void, ie one done for its side-effects. Note
103 -- that this is the only StVoidable we handle.
104 StVoidable (StCall fn cconv VoidRep args)
105 -> genCCall fn cconv VoidRep (map derefDLL args)
107 StAssignMem pk addr src
108 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
109 | ncg_target_is_32bit
110 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
111 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
112 StAssignReg pk reg src
113 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
114 | ncg_target_is_32bit
115 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
116 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
119 -- When falling through on the Alpha, we still have to load pv
120 -- with the address of the next routine, so that it can load gp.
121 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
125 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
126 returnNat (DATA (primRepToSize kind) imms
127 `consOL` concatOL codes)
129 getData :: StixExpr -> NatM (InstrBlock, Imm)
130 getData (StInt i) = returnNat (nilOL, ImmInteger i)
131 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
132 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
133 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
134 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
135 -- the linker can handle simple arithmetic...
136 getData (StIndex rep (StCLbl lbl) (StInt off)) =
138 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
140 -- Top-level lifted-out string. The segment will already have been set
141 -- (see Stix.liftStrings).
143 -> returnNat (unitOL (ASCII True (unpackFS str)))
146 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
149 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
150 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
151 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
153 derefDLL :: StixExpr -> StixExpr
155 | opt_Static -- short out the entire deal if not doing DLLs
162 StCLbl lbl -> if labelDynamic lbl
163 then StInd PtrRep (StCLbl lbl)
165 -- all the rest are boring
166 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
167 StMachOp mop args -> StMachOp mop (map qq args)
168 StInd pk addr -> StInd pk (qq addr)
169 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
170 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
176 _ -> pprPanic "derefDLL: unhandled case"
180 %************************************************************************
182 \subsection{General things for putting together code sequences}
184 %************************************************************************
187 mangleIndexTree :: StixExpr -> StixExpr
189 mangleIndexTree (StIndex pk base (StInt i))
190 = StMachOp MO_Nat_Add [base, off]
192 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
194 mangleIndexTree (StIndex pk base off)
195 = StMachOp MO_Nat_Add [
198 in if s == 0 then off
199 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
202 shift :: PrimRep -> Int
203 shift rep = case getPrimRepSizeInBytes rep of
208 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
209 (Outputable.int other)
213 maybeImm :: StixExpr -> Maybe Imm
217 maybeImm (StIndex rep (StCLbl l) (StInt off))
218 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
220 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
221 = Just (ImmInt (fromInteger i))
223 = Just (ImmInteger i)
228 %************************************************************************
230 \subsection{The @Register64@ type}
232 %************************************************************************
234 Simple support for generating 64-bit code (ie, 64 bit values and 64
235 bit assignments) on 32-bit platforms. Unlike the main code generator
236 we merely shoot for generating working code as simply as possible, and
237 pay little attention to code quality. Specifically, there is no
238 attempt to deal cleverly with the fixed-vs-floating register
239 distinction; all values are generated into (pairs of) floating
240 registers, even if this would mean some redundant reg-reg moves as a
241 result. Only one of the VRegUniques is returned, since it will be
242 of the VRegUniqueLo form, and the upper-half VReg can be determined
243 by applying getHiVRegFromLo to it.
247 data ChildCode64 -- a.k.a "Register64"
250 VRegUnique -- unique for the lower 32-bit temporary
251 -- which contains the result; use getHiVRegFromLo to find
252 -- the other VRegUnique.
253 -- Rules of this simplified insn selection game are
254 -- therefore that the returned VRegUnique may be modified
256 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
257 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
258 iselExpr64 :: StixExpr -> NatM ChildCode64
260 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
264 assignMem_I64Code addrTree valueTree
265 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
266 getRegister addrTree `thenNat` \ register_addr ->
267 getNewRegNCG IntRep `thenNat` \ t_addr ->
268 let rlo = VirtualRegI vrlo
269 rhi = getHiVRegFromLo rlo
270 code_addr = registerCode register_addr t_addr
271 reg_addr = registerName register_addr t_addr
272 -- Little-endian store
273 mov_lo = MOV L (OpReg rlo)
274 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
275 mov_hi = MOV L (OpReg rhi)
276 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
278 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
280 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
281 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
283 r_dst_lo = mkVReg u_dst IntRep
284 r_src_lo = VirtualRegI vr_src_lo
285 r_dst_hi = getHiVRegFromLo r_dst_lo
286 r_src_hi = getHiVRegFromLo r_src_lo
287 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
288 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
291 vcode `snocOL` mov_lo `snocOL` mov_hi
294 assignReg_I64Code lvalue valueTree
295 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
300 iselExpr64 (StInd pk addrTree)
302 = getRegister addrTree `thenNat` \ register_addr ->
303 getNewRegNCG IntRep `thenNat` \ t_addr ->
304 getNewRegNCG IntRep `thenNat` \ rlo ->
305 let rhi = getHiVRegFromLo rlo
306 code_addr = registerCode register_addr t_addr
307 reg_addr = registerName register_addr t_addr
308 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
310 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
314 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
318 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
320 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
321 let r_dst_hi = getHiVRegFromLo r_dst_lo
322 r_src_lo = mkVReg vu IntRep
323 r_src_hi = getHiVRegFromLo r_src_lo
324 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
325 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
328 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
331 iselExpr64 (StCall fn cconv kind args)
333 = genCCall fn cconv kind args `thenNat` \ call ->
334 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
335 let r_dst_hi = getHiVRegFromLo r_dst_lo
336 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
337 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
340 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
341 (getVRegUnique r_dst_lo)
345 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
347 #endif {- i386_TARGET_ARCH -}
349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
351 #if sparc_TARGET_ARCH
353 assignMem_I64Code addrTree valueTree
354 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
355 getRegister addrTree `thenNat` \ register_addr ->
356 getNewRegNCG IntRep `thenNat` \ t_addr ->
357 let rlo = VirtualRegI vrlo
358 rhi = getHiVRegFromLo rlo
359 code_addr = registerCode register_addr t_addr
360 reg_addr = registerName register_addr t_addr
362 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
363 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
365 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
368 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
369 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
371 r_dst_lo = mkVReg u_dst IntRep
372 r_src_lo = VirtualRegI vr_src_lo
373 r_dst_hi = getHiVRegFromLo r_dst_lo
374 r_src_hi = getHiVRegFromLo r_src_lo
375 mov_lo = mkMOV r_src_lo r_dst_lo
376 mov_hi = mkMOV r_src_hi r_dst_hi
377 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
380 vcode `snocOL` mov_hi `snocOL` mov_lo
382 assignReg_I64Code lvalue valueTree
383 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
387 -- Don't delete this -- it's very handy for debugging.
389 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
390 -- = panic "iselExpr64(???)"
392 iselExpr64 (StInd pk addrTree)
394 = getRegister addrTree `thenNat` \ register_addr ->
395 getNewRegNCG IntRep `thenNat` \ t_addr ->
396 getNewRegNCG IntRep `thenNat` \ rlo ->
397 let rhi = getHiVRegFromLo rlo
398 code_addr = registerCode register_addr t_addr
399 reg_addr = registerName register_addr t_addr
400 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
401 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
404 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
408 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
410 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
411 let r_dst_hi = getHiVRegFromLo r_dst_lo
412 r_src_lo = mkVReg vu IntRep
413 r_src_hi = getHiVRegFromLo r_src_lo
414 mov_lo = mkMOV r_src_lo r_dst_lo
415 mov_hi = mkMOV r_src_hi r_dst_hi
416 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
419 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
422 iselExpr64 (StCall fn cconv kind args)
424 = genCCall fn cconv kind args `thenNat` \ call ->
425 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
426 let r_dst_hi = getHiVRegFromLo r_dst_lo
427 mov_lo = mkMOV o0 r_dst_lo
428 mov_hi = mkMOV o1 r_dst_hi
429 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
432 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
433 (getVRegUnique r_dst_lo)
437 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
439 #endif {- sparc_TARGET_ARCH -}
440 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
442 #if powerpc_TARGET_ARCH
444 assignMem_I64Code addrTree valueTree
445 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
446 getRegister addrTree `thenNat` \ register_addr ->
447 getNewRegNCG IntRep `thenNat` \ t_addr ->
448 let rlo = VirtualRegI vrlo
449 rhi = getHiVRegFromLo rlo
450 code_addr = registerCode register_addr t_addr
451 reg_addr = registerName register_addr t_addr
453 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
454 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
456 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
459 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
460 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
462 r_dst_lo = mkVReg u_dst IntRep
463 r_src_lo = VirtualRegI vr_src_lo
464 r_dst_hi = getHiVRegFromLo r_dst_lo
465 r_src_hi = getHiVRegFromLo r_src_lo
466 mov_lo = MR r_dst_lo r_src_lo
467 mov_hi = MR r_dst_hi r_src_hi
470 vcode `snocOL` mov_hi `snocOL` mov_lo
472 assignReg_I64Code lvalue valueTree
473 = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
477 -- Don't delete this -- it's very handy for debugging.
479 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
480 -- = panic "iselExpr64(???)"
482 iselExpr64 (StInd pk addrTree)
484 = getRegister addrTree `thenNat` \ register_addr ->
485 getNewRegNCG IntRep `thenNat` \ t_addr ->
486 getNewRegNCG IntRep `thenNat` \ rlo ->
487 let rhi = getHiVRegFromLo rlo
488 code_addr = registerCode register_addr t_addr
489 reg_addr = registerName register_addr t_addr
490 mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
491 mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
494 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
498 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
500 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
501 let r_dst_hi = getHiVRegFromLo r_dst_lo
502 r_src_lo = mkVReg vu IntRep
503 r_src_hi = getHiVRegFromLo r_src_lo
504 mov_lo = MR r_dst_lo r_src_lo
505 mov_hi = MR r_dst_hi r_src_hi
508 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
511 iselExpr64 (StCall fn cconv kind args)
513 = genCCall fn cconv kind args `thenNat` \ call ->
514 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
515 let r_dst_hi = getHiVRegFromLo r_dst_lo
516 mov_lo = MR r_dst_lo r4
517 mov_hi = MR r_dst_hi r3
520 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
521 (getVRegUnique r_dst_lo)
525 = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
527 #endif {- powerpc_TARGET_ARCH -}
529 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
533 %************************************************************************
535 \subsection{The @Register@ type}
537 %************************************************************************
539 @Register@s passed up the tree. If the stix code forces the register
540 to live in a pre-decided machine register, it comes out as @Fixed@;
541 otherwise, it comes out as @Any@, and the parent can decide which
542 register to put it in.
546 = Fixed PrimRep Reg InstrBlock
547 | Any PrimRep (Reg -> InstrBlock)
549 registerCode :: Register -> Reg -> InstrBlock
550 registerCode (Fixed _ _ code) reg = code
551 registerCode (Any _ code) reg = code reg
553 registerCodeF (Fixed _ _ code) = code
554 registerCodeF (Any _ _) = panic "registerCodeF"
556 registerCodeA (Any _ code) = code
557 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
559 registerName :: Register -> Reg -> Reg
560 registerName (Fixed _ reg _) _ = reg
561 registerName (Any _ _) reg = reg
563 registerNameF (Fixed _ reg _) = reg
564 registerNameF (Any _ _) = panic "registerNameF"
566 registerRep :: Register -> PrimRep
567 registerRep (Fixed pk _ _) = pk
568 registerRep (Any pk _) = pk
570 swizzleRegisterRep :: Register -> PrimRep -> Register
571 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
572 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
574 {-# INLINE registerCode #-}
575 {-# INLINE registerCodeF #-}
576 {-# INLINE registerName #-}
577 {-# INLINE registerNameF #-}
578 {-# INLINE registerRep #-}
579 {-# INLINE isFixed #-}
582 isFixed, isAny :: Register -> Bool
583 isFixed (Fixed _ _ _) = True
584 isFixed (Any _ _) = False
586 isAny = not . isFixed
589 Generate code to get a subtree into a @Register@:
592 getRegisterReg :: StixReg -> NatM Register
593 getRegister :: StixExpr -> NatM Register
596 getRegisterReg (StixMagicId mid)
597 = case get_MagicId_reg_or_addr mid of
599 -> let pk = magicIdPrimRep mid
600 in returnNat (Fixed pk (RealReg rrno) nilOL)
602 -- By this stage, the only MagicIds remaining should be the
603 -- ones which map to a real machine register on this platform. Hence ...
604 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
606 getRegisterReg (StixTemp (StixVReg u pk))
607 = returnNat (Fixed pk (mkVReg u pk) nilOL)
611 -- Don't delete this -- it's very handy for debugging.
613 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
614 -- = panic "getRegister(???)"
616 getRegister (StReg reg)
619 getRegister tree@(StIndex _ _ _)
620 = getRegister (mangleIndexTree tree)
622 getRegister (StCall fn cconv kind args)
623 | not (ncg_target_is_32bit && is64BitRep kind)
624 = genCCall fn cconv kind args `thenNat` \ call ->
625 returnNat (Fixed kind reg call)
627 reg = if isFloatingRep kind
628 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
629 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
631 getRegister (StString s)
632 = getNatLabelNCG `thenNat` \ lbl ->
634 imm_lbl = ImmCLbl lbl
637 SEGMENT RoDataSegment,
639 ASCII True (unpackFS s),
641 #if alpha_TARGET_ARCH
642 LDA dst (AddrImm imm_lbl)
645 MOV L (OpImm imm_lbl) (OpReg dst)
647 #if sparc_TARGET_ARCH
648 SETHI (HI imm_lbl) dst,
649 OR False dst (RIImm (LO imm_lbl)) dst
651 #if powerpc_TARGET_ARCH
652 LIS dst (HI imm_lbl),
653 OR dst dst (RIImm (LO imm_lbl))
657 returnNat (Any PtrRep code)
659 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
660 -- end of machine-"independent" bit; here we go on the rest...
662 #if alpha_TARGET_ARCH
664 getRegister (StDouble d)
665 = getNatLabelNCG `thenNat` \ lbl ->
666 getNewRegNCG PtrRep `thenNat` \ tmp ->
667 let code dst = mkSeqInstrs [
670 DATA TF [ImmLab (rational d)],
672 LDA tmp (AddrImm (ImmCLbl lbl)),
673 LD TF dst (AddrReg tmp)]
675 returnNat (Any DoubleRep code)
677 getRegister (StPrim primop [x]) -- unary PrimOps
679 IntNegOp -> trivialUCode (NEG Q False) x
681 NotOp -> trivialUCode NOT x
683 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
684 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
686 OrdOp -> coerceIntCode IntRep x
689 Float2IntOp -> coerceFP2Int x
690 Int2FloatOp -> coerceInt2FP pr x
691 Double2IntOp -> coerceFP2Int x
692 Int2DoubleOp -> coerceInt2FP pr x
694 Double2FloatOp -> coerceFltCode x
695 Float2DoubleOp -> coerceFltCode x
697 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
699 fn = case other_op of
700 FloatExpOp -> FSLIT("exp")
701 FloatLogOp -> FSLIT("log")
702 FloatSqrtOp -> FSLIT("sqrt")
703 FloatSinOp -> FSLIT("sin")
704 FloatCosOp -> FSLIT("cos")
705 FloatTanOp -> FSLIT("tan")
706 FloatAsinOp -> FSLIT("asin")
707 FloatAcosOp -> FSLIT("acos")
708 FloatAtanOp -> FSLIT("atan")
709 FloatSinhOp -> FSLIT("sinh")
710 FloatCoshOp -> FSLIT("cosh")
711 FloatTanhOp -> FSLIT("tanh")
712 DoubleExpOp -> FSLIT("exp")
713 DoubleLogOp -> FSLIT("log")
714 DoubleSqrtOp -> FSLIT("sqrt")
715 DoubleSinOp -> FSLIT("sin")
716 DoubleCosOp -> FSLIT("cos")
717 DoubleTanOp -> FSLIT("tan")
718 DoubleAsinOp -> FSLIT("asin")
719 DoubleAcosOp -> FSLIT("acos")
720 DoubleAtanOp -> FSLIT("atan")
721 DoubleSinhOp -> FSLIT("sinh")
722 DoubleCoshOp -> FSLIT("cosh")
723 DoubleTanhOp -> FSLIT("tanh")
725 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
727 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
729 CharGtOp -> trivialCode (CMP LTT) y x
730 CharGeOp -> trivialCode (CMP LE) y x
731 CharEqOp -> trivialCode (CMP EQQ) x y
732 CharNeOp -> int_NE_code x y
733 CharLtOp -> trivialCode (CMP LTT) x y
734 CharLeOp -> trivialCode (CMP LE) x y
736 IntGtOp -> trivialCode (CMP LTT) y x
737 IntGeOp -> trivialCode (CMP LE) y x
738 IntEqOp -> trivialCode (CMP EQQ) x y
739 IntNeOp -> int_NE_code x y
740 IntLtOp -> trivialCode (CMP LTT) x y
741 IntLeOp -> trivialCode (CMP LE) x y
743 WordGtOp -> trivialCode (CMP ULT) y x
744 WordGeOp -> trivialCode (CMP ULE) x y
745 WordEqOp -> trivialCode (CMP EQQ) x y
746 WordNeOp -> int_NE_code x y
747 WordLtOp -> trivialCode (CMP ULT) x y
748 WordLeOp -> trivialCode (CMP ULE) x y
750 AddrGtOp -> trivialCode (CMP ULT) y x
751 AddrGeOp -> trivialCode (CMP ULE) y x
752 AddrEqOp -> trivialCode (CMP EQQ) x y
753 AddrNeOp -> int_NE_code x y
754 AddrLtOp -> trivialCode (CMP ULT) x y
755 AddrLeOp -> trivialCode (CMP ULE) x y
757 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
758 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
759 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
760 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
761 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
762 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
764 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
765 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
766 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
767 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
768 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
769 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
771 IntAddOp -> trivialCode (ADD Q False) x y
772 IntSubOp -> trivialCode (SUB Q False) x y
773 IntMulOp -> trivialCode (MUL Q False) x y
774 IntQuotOp -> trivialCode (DIV Q False) x y
775 IntRemOp -> trivialCode (REM Q False) x y
777 WordAddOp -> trivialCode (ADD Q False) x y
778 WordSubOp -> trivialCode (SUB Q False) x y
779 WordMulOp -> trivialCode (MUL Q False) x y
780 WordQuotOp -> trivialCode (DIV Q True) x y
781 WordRemOp -> trivialCode (REM Q True) x y
783 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
784 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
785 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
786 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
788 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
789 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
790 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
791 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
793 AddrAddOp -> trivialCode (ADD Q False) x y
794 AddrSubOp -> trivialCode (SUB Q False) x y
795 AddrRemOp -> trivialCode (REM Q True) x y
797 AndOp -> trivialCode AND x y
798 OrOp -> trivialCode OR x y
799 XorOp -> trivialCode XOR x y
800 SllOp -> trivialCode SLL x y
801 SrlOp -> trivialCode SRL x y
803 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
804 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
805 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
807 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
808 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
810 {- ------------------------------------------------------------
811 Some bizarre special code for getting condition codes into
812 registers. Integer non-equality is a test for equality
813 followed by an XOR with 1. (Integer comparisons always set
814 the result register to 0 or 1.) Floating point comparisons of
815 any kind leave the result in a floating point register, so we
816 need to wrangle an integer register out of things.
818 int_NE_code :: StixTree -> StixTree -> NatM Register
821 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
822 getNewRegNCG IntRep `thenNat` \ tmp ->
824 code = registerCode register tmp
825 src = registerName register tmp
826 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
828 returnNat (Any IntRep code__2)
830 {- ------------------------------------------------------------
831 Comments for int_NE_code also apply to cmpF_code
834 :: (Reg -> Reg -> Reg -> Instr)
836 -> StixTree -> StixTree
839 cmpF_code instr cond x y
840 = trivialFCode pr instr x y `thenNat` \ register ->
841 getNewRegNCG DoubleRep `thenNat` \ tmp ->
842 getNatLabelNCG `thenNat` \ lbl ->
844 code = registerCode register tmp
845 result = registerName register tmp
847 code__2 dst = code . mkSeqInstrs [
848 OR zeroh (RIImm (ImmInt 1)) dst,
849 BF cond result (ImmCLbl lbl),
850 OR zeroh (RIReg zeroh) dst,
853 returnNat (Any IntRep code__2)
855 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
856 ------------------------------------------------------------
858 getRegister (StInd pk mem)
859 = getAmode mem `thenNat` \ amode ->
861 code = amodeCode amode
862 src = amodeAddr amode
863 size = primRepToSize pk
864 code__2 dst = code . mkSeqInstr (LD size dst src)
866 returnNat (Any pk code__2)
868 getRegister (StInt i)
871 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
873 returnNat (Any IntRep code)
876 code dst = mkSeqInstr (LDI Q dst src)
878 returnNat (Any IntRep code)
880 src = ImmInt (fromInteger i)
885 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
887 returnNat (Any PtrRep code)
890 imm__2 = case imm of Just x -> x
892 #endif {- alpha_TARGET_ARCH -}
894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
898 getRegister (StFloat f)
899 = getNatLabelNCG `thenNat` \ lbl ->
900 let code dst = toOL [
905 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
908 returnNat (Any FloatRep code)
911 getRegister (StDouble d)
914 = let code dst = unitOL (GLDZ dst)
915 in returnNat (Any DoubleRep code)
918 = let code dst = unitOL (GLD1 dst)
919 in returnNat (Any DoubleRep code)
922 = getNatLabelNCG `thenNat` \ lbl ->
923 let code dst = toOL [
926 DATA DF [ImmDouble d],
928 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
931 returnNat (Any DoubleRep code)
934 getRegister (StMachOp mop [x]) -- unary MachOps
936 MO_NatS_Neg -> trivialUCode (NEGI L) x
937 MO_Nat_Not -> trivialUCode (NOT L) x
938 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
940 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
941 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
943 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
944 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
946 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
947 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
949 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
950 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
952 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
953 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
955 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
956 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
957 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
958 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
960 -- Conversions which are a nop on x86
961 MO_32U_to_NatS -> conversionNop IntRep x
962 MO_32S_to_NatS -> conversionNop IntRep x
963 MO_NatS_to_32U -> conversionNop WordRep x
964 MO_32U_to_NatU -> conversionNop WordRep x
966 MO_NatU_to_NatS -> conversionNop IntRep x
967 MO_NatS_to_NatU -> conversionNop WordRep x
968 MO_NatP_to_NatU -> conversionNop WordRep x
969 MO_NatU_to_NatP -> conversionNop PtrRep x
970 MO_NatS_to_NatP -> conversionNop PtrRep x
971 MO_NatP_to_NatS -> conversionNop IntRep x
973 MO_Dbl_to_Flt -> conversionNop FloatRep x
974 MO_Flt_to_Dbl -> conversionNop DoubleRep x
976 -- sign-extending widenings
977 MO_8U_to_NatU -> integerExtend False 24 x
978 MO_8S_to_NatS -> integerExtend True 24 x
979 MO_16U_to_NatU -> integerExtend False 16 x
980 MO_16S_to_NatS -> integerExtend True 16 x
981 MO_8U_to_32U -> integerExtend False 24 x
985 (if is_float_op then demote else id)
986 (StCall (Left fn) CCallConv DoubleRep
987 [(if is_float_op then promote else id) x])
990 integerExtend signed nBits x
992 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
993 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
996 conversionNop new_rep expr
997 = getRegister expr `thenNat` \ e_code ->
998 returnNat (swizzleRegisterRep e_code new_rep)
1000 promote x = StMachOp MO_Flt_to_Dbl [x]
1001 demote x = StMachOp MO_Dbl_to_Flt [x]
1004 MO_Flt_Exp -> (True, FSLIT("exp"))
1005 MO_Flt_Log -> (True, FSLIT("log"))
1007 MO_Flt_Asin -> (True, FSLIT("asin"))
1008 MO_Flt_Acos -> (True, FSLIT("acos"))
1009 MO_Flt_Atan -> (True, FSLIT("atan"))
1011 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1012 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1013 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1015 MO_Dbl_Exp -> (False, FSLIT("exp"))
1016 MO_Dbl_Log -> (False, FSLIT("log"))
1018 MO_Dbl_Asin -> (False, FSLIT("asin"))
1019 MO_Dbl_Acos -> (False, FSLIT("acos"))
1020 MO_Dbl_Atan -> (False, FSLIT("atan"))
1022 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1023 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1024 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1026 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
1030 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
1032 MO_32U_Gt -> condIntReg GTT x y
1033 MO_32U_Ge -> condIntReg GE x y
1034 MO_32U_Eq -> condIntReg EQQ x y
1035 MO_32U_Ne -> condIntReg NE x y
1036 MO_32U_Lt -> condIntReg LTT x y
1037 MO_32U_Le -> condIntReg LE x y
1039 MO_Nat_Eq -> condIntReg EQQ x y
1040 MO_Nat_Ne -> condIntReg NE x y
1042 MO_NatS_Gt -> condIntReg GTT x y
1043 MO_NatS_Ge -> condIntReg GE x y
1044 MO_NatS_Lt -> condIntReg LTT x y
1045 MO_NatS_Le -> condIntReg LE x y
1047 MO_NatU_Gt -> condIntReg GU x y
1048 MO_NatU_Ge -> condIntReg GEU x y
1049 MO_NatU_Lt -> condIntReg LU x y
1050 MO_NatU_Le -> condIntReg LEU x y
1052 MO_Flt_Gt -> condFltReg GTT x y
1053 MO_Flt_Ge -> condFltReg GE x y
1054 MO_Flt_Eq -> condFltReg EQQ x y
1055 MO_Flt_Ne -> condFltReg NE x y
1056 MO_Flt_Lt -> condFltReg LTT x y
1057 MO_Flt_Le -> condFltReg LE x y
1059 MO_Dbl_Gt -> condFltReg GTT x y
1060 MO_Dbl_Ge -> condFltReg GE x y
1061 MO_Dbl_Eq -> condFltReg EQQ x y
1062 MO_Dbl_Ne -> condFltReg NE x y
1063 MO_Dbl_Lt -> condFltReg LTT x y
1064 MO_Dbl_Le -> condFltReg LE x y
1066 MO_Nat_Add -> add_code L x y
1067 MO_Nat_Sub -> sub_code L x y
1068 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
1069 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
1070 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
1071 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
1072 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
1073 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
1074 MO_NatS_MulMayOflo -> imulMayOflo x y
1076 MO_Flt_Add -> trivialFCode FloatRep GADD x y
1077 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
1078 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
1079 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
1081 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
1082 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
1083 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
1084 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
1086 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
1087 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
1088 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1090 {- Shift ops on x86s have constraints on their source, it
1091 either has to be Imm, CL or 1
1092 => trivialCode's is not restrictive enough (sigh.)
1094 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
1095 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1096 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1098 MO_Flt_Pwr -> getRegister (demote
1099 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1100 [promote x, promote y])
1102 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1104 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1106 promote x = StMachOp MO_Flt_to_Dbl [x]
1107 demote x = StMachOp MO_Dbl_to_Flt [x]
1109 --------------------
1110 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1112 = getNewRegNCG IntRep `thenNat` \ t1 ->
1113 getNewRegNCG IntRep `thenNat` \ t2 ->
1114 getNewRegNCG IntRep `thenNat` \ res_lo ->
1115 getNewRegNCG IntRep `thenNat` \ res_hi ->
1116 getRegister a1 `thenNat` \ reg1 ->
1117 getRegister a2 `thenNat` \ reg2 ->
1118 let code1 = registerCode reg1 t1
1119 code2 = registerCode reg2 t2
1120 src1 = registerName reg1 t1
1121 src2 = registerName reg2 t2
1122 code dst = code1 `appOL` code2 `appOL`
1124 MOV L (OpReg src1) (OpReg res_hi),
1125 MOV L (OpReg src2) (OpReg res_lo),
1126 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1127 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1128 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1129 MOV L (OpReg res_lo) (OpReg dst)
1130 -- dst==0 if high part == sign extended low part
1133 returnNat (Any IntRep code)
1135 --------------------
1136 shift_code :: (Imm -> Operand -> Instr)
1141 {- Case1: shift length as immediate -}
1142 -- Code is the same as the first eq. for trivialCode -- sigh.
1143 shift_code instr x y{-amount-}
1145 = getRegister x `thenNat` \ regx ->
1148 then registerCodeA regx dst `bind` \ code_x ->
1150 instr imm__2 (OpReg dst)
1151 else registerCodeF regx `bind` \ code_x ->
1152 registerNameF regx `bind` \ r_x ->
1154 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1155 instr imm__2 (OpReg dst)
1157 returnNat (Any IntRep mkcode)
1160 imm__2 = case imm of Just x -> x
1162 {- Case2: shift length is complex (non-immediate) -}
1163 -- Since ECX is always used as a spill temporary, we can't
1164 -- use it here to do non-immediate shifts. No big deal --
1165 -- they are only very rare, and we can use an equivalent
1166 -- test-and-jump sequence which doesn't use ECX.
1167 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1168 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1169 shift_code instr x y{-amount-}
1170 = getRegister x `thenNat` \ register1 ->
1171 getRegister y `thenNat` \ register2 ->
1172 getNatLabelNCG `thenNat` \ lbl_test3 ->
1173 getNatLabelNCG `thenNat` \ lbl_test2 ->
1174 getNatLabelNCG `thenNat` \ lbl_test1 ->
1175 getNatLabelNCG `thenNat` \ lbl_test0 ->
1176 getNatLabelNCG `thenNat` \ lbl_after ->
1177 getNewRegNCG IntRep `thenNat` \ tmp ->
1179 = let src_val = registerName register1 dst
1180 code_val = registerCode register1 dst
1181 src_amt = registerName register2 tmp
1182 code_amt = registerCode register2 tmp
1187 MOV L (OpReg src_amt) r_tmp `appOL`
1189 MOV L (OpReg src_val) r_dst `appOL`
1191 COMMENT (mkFastString "begin shift sequence"),
1192 MOV L (OpReg src_val) r_dst,
1193 MOV L (OpReg src_amt) r_tmp,
1195 BT L (ImmInt 4) r_tmp,
1197 instr (ImmInt 16) r_dst,
1200 BT L (ImmInt 3) r_tmp,
1202 instr (ImmInt 8) r_dst,
1205 BT L (ImmInt 2) r_tmp,
1207 instr (ImmInt 4) r_dst,
1210 BT L (ImmInt 1) r_tmp,
1212 instr (ImmInt 2) r_dst,
1215 BT L (ImmInt 0) r_tmp,
1217 instr (ImmInt 1) r_dst,
1220 COMMENT (mkFastString "end shift sequence")
1223 returnNat (Any IntRep code__2)
1225 --------------------
1226 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1228 add_code sz x (StInt y)
1229 = getRegister x `thenNat` \ register ->
1230 getNewRegNCG IntRep `thenNat` \ tmp ->
1232 code = registerCode register tmp
1233 src1 = registerName register tmp
1234 src2 = ImmInt (fromInteger y)
1237 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1240 returnNat (Any IntRep code__2)
1242 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1244 --------------------
1245 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1247 sub_code sz x (StInt y)
1248 = getRegister x `thenNat` \ register ->
1249 getNewRegNCG IntRep `thenNat` \ tmp ->
1251 code = registerCode register tmp
1252 src1 = registerName register tmp
1253 src2 = ImmInt (-(fromInteger y))
1256 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1259 returnNat (Any IntRep code__2)
1261 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1263 getRegister (StInd pk mem)
1264 | not (is64BitRep pk)
1265 = getAmode mem `thenNat` \ amode ->
1267 code = amodeCode amode
1268 src = amodeAddr amode
1269 size = primRepToSize pk
1270 code__2 dst = code `snocOL`
1271 if pk == DoubleRep || pk == FloatRep
1272 then GLD size src dst
1280 (OpAddr src) (OpReg dst)
1282 returnNat (Any pk code__2)
1284 getRegister (StInt i)
1286 src = ImmInt (fromInteger i)
1289 = unitOL (XOR L (OpReg dst) (OpReg dst))
1291 = unitOL (MOV L (OpImm src) (OpReg dst))
1293 returnNat (Any IntRep code)
1297 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1299 returnNat (Any PtrRep code)
1301 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1304 imm__2 = case imm of Just x -> x
1306 #endif {- i386_TARGET_ARCH -}
1308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1310 #if sparc_TARGET_ARCH
1312 getRegister (StFloat d)
1313 = getNatLabelNCG `thenNat` \ lbl ->
1314 getNewRegNCG PtrRep `thenNat` \ tmp ->
1315 let code dst = toOL [
1316 SEGMENT DataSegment,
1318 DATA F [ImmFloat d],
1319 SEGMENT TextSegment,
1320 SETHI (HI (ImmCLbl lbl)) tmp,
1321 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1323 returnNat (Any FloatRep code)
1325 getRegister (StDouble d)
1326 = getNatLabelNCG `thenNat` \ lbl ->
1327 getNewRegNCG PtrRep `thenNat` \ tmp ->
1328 let code dst = toOL [
1329 SEGMENT DataSegment,
1331 DATA DF [ImmDouble d],
1332 SEGMENT TextSegment,
1333 SETHI (HI (ImmCLbl lbl)) tmp,
1334 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1336 returnNat (Any DoubleRep code)
1339 getRegister (StMachOp mop [x]) -- unary PrimOps
1341 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1342 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1343 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1345 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1346 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1348 MO_Dbl_to_Flt -> coerceDbl2Flt x
1349 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1351 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1352 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1353 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1354 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1356 -- Conversions which are a nop on sparc
1357 MO_32U_to_NatS -> conversionNop IntRep x
1358 MO_32S_to_NatS -> conversionNop IntRep x
1359 MO_NatS_to_32U -> conversionNop WordRep x
1360 MO_32U_to_NatU -> conversionNop WordRep x
1362 MO_NatU_to_NatS -> conversionNop IntRep x
1363 MO_NatS_to_NatU -> conversionNop WordRep x
1364 MO_NatP_to_NatU -> conversionNop WordRep x
1365 MO_NatU_to_NatP -> conversionNop PtrRep x
1366 MO_NatS_to_NatP -> conversionNop PtrRep x
1367 MO_NatP_to_NatS -> conversionNop IntRep x
1369 -- sign-extending widenings
1370 MO_8U_to_32U -> integerExtend False 24 x
1371 MO_8U_to_NatU -> integerExtend False 24 x
1372 MO_8S_to_NatS -> integerExtend True 24 x
1373 MO_16U_to_NatU -> integerExtend False 16 x
1374 MO_16S_to_NatS -> integerExtend True 16 x
1377 let fixed_x = if is_float_op -- promote to double
1378 then StMachOp MO_Flt_to_Dbl [x]
1381 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1383 integerExtend signed nBits x
1385 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1386 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1388 conversionNop new_rep expr
1389 = getRegister expr `thenNat` \ e_code ->
1390 returnNat (swizzleRegisterRep e_code new_rep)
1394 MO_Flt_Exp -> (True, FSLIT("exp"))
1395 MO_Flt_Log -> (True, FSLIT("log"))
1396 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1398 MO_Flt_Sin -> (True, FSLIT("sin"))
1399 MO_Flt_Cos -> (True, FSLIT("cos"))
1400 MO_Flt_Tan -> (True, FSLIT("tan"))
1402 MO_Flt_Asin -> (True, FSLIT("asin"))
1403 MO_Flt_Acos -> (True, FSLIT("acos"))
1404 MO_Flt_Atan -> (True, FSLIT("atan"))
1406 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1407 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1408 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1410 MO_Dbl_Exp -> (False, FSLIT("exp"))
1411 MO_Dbl_Log -> (False, FSLIT("log"))
1412 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1414 MO_Dbl_Sin -> (False, FSLIT("sin"))
1415 MO_Dbl_Cos -> (False, FSLIT("cos"))
1416 MO_Dbl_Tan -> (False, FSLIT("tan"))
1418 MO_Dbl_Asin -> (False, FSLIT("asin"))
1419 MO_Dbl_Acos -> (False, FSLIT("acos"))
1420 MO_Dbl_Atan -> (False, FSLIT("atan"))
1422 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1423 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1424 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1426 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1430 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1432 MO_32U_Gt -> condIntReg GTT x y
1433 MO_32U_Ge -> condIntReg GE x y
1434 MO_32U_Eq -> condIntReg EQQ x y
1435 MO_32U_Ne -> condIntReg NE x y
1436 MO_32U_Lt -> condIntReg LTT x y
1437 MO_32U_Le -> condIntReg LE x y
1439 MO_Nat_Eq -> condIntReg EQQ x y
1440 MO_Nat_Ne -> condIntReg NE x y
1442 MO_NatS_Gt -> condIntReg GTT x y
1443 MO_NatS_Ge -> condIntReg GE x y
1444 MO_NatS_Lt -> condIntReg LTT x y
1445 MO_NatS_Le -> condIntReg LE x y
1447 MO_NatU_Gt -> condIntReg GU x y
1448 MO_NatU_Ge -> condIntReg GEU x y
1449 MO_NatU_Lt -> condIntReg LU x y
1450 MO_NatU_Le -> condIntReg LEU x y
1452 MO_Flt_Gt -> condFltReg GTT x y
1453 MO_Flt_Ge -> condFltReg GE x y
1454 MO_Flt_Eq -> condFltReg EQQ x y
1455 MO_Flt_Ne -> condFltReg NE x y
1456 MO_Flt_Lt -> condFltReg LTT x y
1457 MO_Flt_Le -> condFltReg LE x y
1459 MO_Dbl_Gt -> condFltReg GTT x y
1460 MO_Dbl_Ge -> condFltReg GE x y
1461 MO_Dbl_Eq -> condFltReg EQQ x y
1462 MO_Dbl_Ne -> condFltReg NE x y
1463 MO_Dbl_Lt -> condFltReg LTT x y
1464 MO_Dbl_Le -> condFltReg LE x y
1466 MO_Nat_Add -> trivialCode (ADD False False) x y
1467 MO_Nat_Sub -> trivialCode (SUB False False) x y
1469 MO_NatS_Mul -> trivialCode (SMUL False) x y
1470 MO_NatU_Mul -> trivialCode (UMUL False) x y
1471 MO_NatS_MulMayOflo -> imulMayOflo x y
1473 -- ToDo: teach about V8+ SPARC div instructions
1474 MO_NatS_Quot -> idiv FSLIT(".div") x y
1475 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1476 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1477 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1479 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1480 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1481 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1482 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1484 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1485 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1486 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1487 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1489 MO_Nat_And -> trivialCode (AND False) x y
1490 MO_Nat_Or -> trivialCode (OR False) x y
1491 MO_Nat_Xor -> trivialCode (XOR False) x y
1493 MO_Nat_Shl -> trivialCode SLL x y
1494 MO_Nat_Shr -> trivialCode SRL x y
1495 MO_Nat_Sar -> trivialCode SRA x y
1497 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1498 [promote x, promote y])
1499 where promote x = StMachOp MO_Flt_to_Dbl [x]
1500 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1503 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1505 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1507 --------------------
1508 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1510 = getNewRegNCG IntRep `thenNat` \ t1 ->
1511 getNewRegNCG IntRep `thenNat` \ t2 ->
1512 getNewRegNCG IntRep `thenNat` \ res_lo ->
1513 getNewRegNCG IntRep `thenNat` \ res_hi ->
1514 getRegister a1 `thenNat` \ reg1 ->
1515 getRegister a2 `thenNat` \ reg2 ->
1516 let code1 = registerCode reg1 t1
1517 code2 = registerCode reg2 t2
1518 src1 = registerName reg1 t1
1519 src2 = registerName reg2 t2
1520 code dst = code1 `appOL` code2 `appOL`
1522 SMUL False src1 (RIReg src2) res_lo,
1524 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1525 SUB False False res_lo (RIReg res_hi) dst
1528 returnNat (Any IntRep code)
1530 getRegister (StInd pk mem)
1531 = getAmode mem `thenNat` \ amode ->
1533 code = amodeCode amode
1534 src = amodeAddr amode
1535 size = primRepToSize pk
1536 code__2 dst = code `snocOL` LD size src dst
1538 returnNat (Any pk code__2)
1540 getRegister (StInt i)
1543 src = ImmInt (fromInteger i)
1544 code dst = unitOL (OR False g0 (RIImm src) dst)
1546 returnNat (Any IntRep code)
1552 SETHI (HI imm__2) dst,
1553 OR False dst (RIImm (LO imm__2)) dst]
1555 returnNat (Any PtrRep code)
1557 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1560 imm__2 = case imm of Just x -> x
1562 #endif {- sparc_TARGET_ARCH -}
1564 #if powerpc_TARGET_ARCH
1565 getRegister (StMachOp mop [x]) -- unary MachOps
1567 MO_NatS_Neg -> trivialUCode NEG x
1568 MO_Nat_Not -> trivialUCode NOT x
1569 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1571 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1572 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1573 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1574 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1576 -- Conversions which are a nop on PPC
1577 MO_NatS_to_32U -> conversionNop WordRep x
1578 MO_32U_to_NatS -> conversionNop IntRep x
1579 MO_32U_to_NatU -> conversionNop WordRep x
1581 MO_NatU_to_NatS -> conversionNop IntRep x
1582 MO_NatS_to_NatU -> conversionNop WordRep x
1583 MO_NatP_to_NatU -> conversionNop WordRep x
1584 MO_NatU_to_NatP -> conversionNop PtrRep x
1585 MO_NatS_to_NatP -> conversionNop PtrRep x
1586 MO_NatP_to_NatS -> conversionNop IntRep x
1588 MO_Dbl_to_Flt -> conversionNop FloatRep x
1589 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1591 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1592 MO_8U_to_NatU -> integerExtend False 24 x
1593 MO_8S_to_NatS -> integerExtend True 24 x
1594 MO_16U_to_NatU -> integerExtend False 16 x
1595 MO_16S_to_NatS -> integerExtend True 16 x
1596 MO_8U_to_32U -> integerExtend False 24 x
1598 MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
1599 MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
1601 other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
1603 integerExtend signed nBits x
1605 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1606 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1608 conversionNop new_rep expr
1609 = getRegister expr `thenNat` \ e_code ->
1610 returnNat (swizzleRegisterRep e_code new_rep)
1614 MO_Flt_Exp -> (True, FSLIT("exp"))
1615 MO_Flt_Log -> (True, FSLIT("log"))
1616 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1618 MO_Flt_Sin -> (True, FSLIT("sin"))
1619 MO_Flt_Cos -> (True, FSLIT("cos"))
1620 MO_Flt_Tan -> (True, FSLIT("tan"))
1622 MO_Flt_Asin -> (True, FSLIT("asin"))
1623 MO_Flt_Acos -> (True, FSLIT("acos"))
1624 MO_Flt_Atan -> (True, FSLIT("atan"))
1626 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1627 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1628 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1630 MO_Dbl_Exp -> (False, FSLIT("exp"))
1631 MO_Dbl_Log -> (False, FSLIT("log"))
1632 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1634 MO_Dbl_Sin -> (False, FSLIT("sin"))
1635 MO_Dbl_Cos -> (False, FSLIT("cos"))
1636 MO_Dbl_Tan -> (False, FSLIT("tan"))
1638 MO_Dbl_Asin -> (False, FSLIT("asin"))
1639 MO_Dbl_Acos -> (False, FSLIT("acos"))
1640 MO_Dbl_Atan -> (False, FSLIT("atan"))
1642 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1643 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1644 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1646 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1650 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1652 MO_32U_Gt -> condIntReg GTT x y
1653 MO_32U_Ge -> condIntReg GE x y
1654 MO_32U_Eq -> condIntReg EQQ x y
1655 MO_32U_Ne -> condIntReg NE x y
1656 MO_32U_Lt -> condIntReg LTT x y
1657 MO_32U_Le -> condIntReg LE x y
1659 MO_Nat_Eq -> condIntReg EQQ x y
1660 MO_Nat_Ne -> condIntReg NE x y
1662 MO_NatS_Gt -> condIntReg GTT x y
1663 MO_NatS_Ge -> condIntReg GE x y
1664 MO_NatS_Lt -> condIntReg LTT x y
1665 MO_NatS_Le -> condIntReg LE x y
1667 MO_NatU_Gt -> condIntReg GU x y
1668 MO_NatU_Ge -> condIntReg GEU x y
1669 MO_NatU_Lt -> condIntReg LU x y
1670 MO_NatU_Le -> condIntReg LEU x y
1672 MO_Flt_Gt -> condFltReg GTT x y
1673 MO_Flt_Ge -> condFltReg GE x y
1674 MO_Flt_Eq -> condFltReg EQQ x y
1675 MO_Flt_Ne -> condFltReg NE x y
1676 MO_Flt_Lt -> condFltReg LTT x y
1677 MO_Flt_Le -> condFltReg LE x y
1679 MO_Dbl_Gt -> condFltReg GTT x y
1680 MO_Dbl_Ge -> condFltReg GE x y
1681 MO_Dbl_Eq -> condFltReg EQQ x y
1682 MO_Dbl_Ne -> condFltReg NE x y
1683 MO_Dbl_Lt -> condFltReg LTT x y
1684 MO_Dbl_Le -> condFltReg LE x y
1686 MO_Nat_Add -> trivialCode ADD x y
1687 MO_Nat_Sub -> trivialCode SUBF y x
1689 MO_NatS_Mul -> trivialCode MULLW x y
1690 MO_NatU_Mul -> trivialCode MULLW x y
1691 -- MO_NatS_MulMayOflo ->
1693 MO_NatS_Quot -> trivialCode2 DIVW x y
1694 MO_NatU_Quot -> trivialCode2 DIVWU x y
1696 MO_NatS_Rem -> remainderCode DIVW x y
1697 MO_NatU_Rem -> remainderCode DIVWU x y
1699 MO_Nat_And -> trivialCode AND x y
1700 MO_Nat_Or -> trivialCode OR x y
1701 MO_Nat_Xor -> trivialCode XOR x y
1703 MO_Nat_Shl -> trivialCode SLW x y
1704 MO_Nat_Shr -> trivialCode SRW x y
1705 MO_Nat_Sar -> trivialCode SRAW x y
1707 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1708 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1709 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1710 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1712 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1713 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1714 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1715 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1717 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1719 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1722 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1724 getRegister (StInd pk mem)
1725 = getAmode mem `thenNat` \ amode ->
1727 code = amodeCode amode
1728 src = amodeAddr amode
1729 size = primRepToSize pk
1730 code__2 dst = code `snocOL` LD size dst src
1732 returnNat (Any pk code__2)
1734 getRegister (StInt i)
1737 src = ImmInt (fromInteger i)
1738 code dst = unitOL (LI dst src)
1740 returnNat (Any IntRep code)
1742 getRegister (StFloat d)
1743 = getNatLabelNCG `thenNat` \ lbl ->
1744 getNewRegNCG PtrRep `thenNat` \ tmp ->
1745 let code dst = toOL [
1746 SEGMENT RoDataSegment,
1748 DATA F [ImmFloat d],
1749 SEGMENT TextSegment,
1750 LIS tmp (HA (ImmCLbl lbl)),
1751 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1753 returnNat (Any FloatRep code)
1755 getRegister (StDouble d)
1756 = getNatLabelNCG `thenNat` \ lbl ->
1757 getNewRegNCG PtrRep `thenNat` \ tmp ->
1758 let code dst = toOL [
1759 SEGMENT RoDataSegment,
1761 DATA DF [ImmDouble d],
1762 SEGMENT TextSegment,
1763 LIS tmp (HA (ImmCLbl lbl)),
1764 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1766 returnNat (Any DoubleRep code)
1772 LIS dst (HI imm__2),
1773 OR dst dst (RIImm (LO imm__2))]
1775 returnNat (Any PtrRep code)
1777 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1780 imm__2 = case imm of Just x -> x
1781 #endif {- powerpc_TARGET_ARCH -}
1783 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1785 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1789 %************************************************************************
1791 \subsection{The @Amode@ type}
1793 %************************************************************************
1795 @Amode@s: Memory addressing modes passed up the tree.
1797 data Amode = Amode MachRegsAddr InstrBlock
1799 amodeAddr (Amode addr _) = addr
1800 amodeCode (Amode _ code) = code
1803 Now, given a tree (the argument to an StInd) that references memory,
1804 produce a suitable addressing mode.
1806 A Rule of the Game (tm) for Amodes: use of the addr bit must
1807 immediately follow use of the code part, since the code part puts
1808 values in registers which the addr then refers to. So you can't put
1809 anything in between, lest it overwrite some of those registers. If
1810 you need to do some other computation between the code part and use of
1811 the addr bit, first store the effective address from the amode in a
1812 temporary, then do the other computation, and then use the temporary:
1816 ... other computation ...
1820 getAmode :: StixExpr -> NatM Amode
1822 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1824 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1826 #if alpha_TARGET_ARCH
1828 getAmode (StPrim IntSubOp [x, StInt i])
1829 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1830 getRegister x `thenNat` \ register ->
1832 code = registerCode register tmp
1833 reg = registerName register tmp
1834 off = ImmInt (-(fromInteger i))
1836 returnNat (Amode (AddrRegImm reg off) code)
1838 getAmode (StPrim IntAddOp [x, StInt i])
1839 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1840 getRegister x `thenNat` \ register ->
1842 code = registerCode register tmp
1843 reg = registerName register tmp
1844 off = ImmInt (fromInteger i)
1846 returnNat (Amode (AddrRegImm reg off) code)
1850 = returnNat (Amode (AddrImm imm__2) id)
1853 imm__2 = case imm of Just x -> x
1856 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1857 getRegister other `thenNat` \ register ->
1859 code = registerCode register tmp
1860 reg = registerName register tmp
1862 returnNat (Amode (AddrReg reg) code)
1864 #endif {- alpha_TARGET_ARCH -}
1866 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1868 #if i386_TARGET_ARCH
1870 -- This is all just ridiculous, since it carefully undoes
1871 -- what mangleIndexTree has just done.
1872 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1873 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1874 getRegister x `thenNat` \ register ->
1876 code = registerCode register tmp
1877 reg = registerName register tmp
1878 off = ImmInt (-(fromInteger i))
1880 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1882 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1884 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1887 imm__2 = case imm of Just x -> x
1889 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1890 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1891 getRegister x `thenNat` \ register ->
1893 code = registerCode register tmp
1894 reg = registerName register tmp
1895 off = ImmInt (fromInteger i)
1897 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1899 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1900 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1901 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1902 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1903 getRegister x `thenNat` \ register1 ->
1904 getRegister y `thenNat` \ register2 ->
1906 code1 = registerCode register1 tmp1
1907 reg1 = registerName register1 tmp1
1908 code2 = registerCode register2 tmp2
1909 reg2 = registerName register2 tmp2
1910 code__2 = code1 `appOL` code2
1911 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1913 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1918 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1921 imm__2 = case imm of Just x -> x
1924 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1925 getRegister other `thenNat` \ register ->
1927 code = registerCode register tmp
1928 reg = registerName register tmp
1930 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1932 #endif {- i386_TARGET_ARCH -}
1934 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1936 #if sparc_TARGET_ARCH
1938 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1940 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1941 getRegister x `thenNat` \ register ->
1943 code = registerCode register tmp
1944 reg = registerName register tmp
1945 off = ImmInt (-(fromInteger i))
1947 returnNat (Amode (AddrRegImm reg off) code)
1950 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1952 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1953 getRegister x `thenNat` \ register ->
1955 code = registerCode register tmp
1956 reg = registerName register tmp
1957 off = ImmInt (fromInteger i)
1959 returnNat (Amode (AddrRegImm reg off) code)
1961 getAmode (StMachOp MO_Nat_Add [x, y])
1962 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1963 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1964 getRegister x `thenNat` \ register1 ->
1965 getRegister y `thenNat` \ register2 ->
1967 code1 = registerCode register1 tmp1
1968 reg1 = registerName register1 tmp1
1969 code2 = registerCode register2 tmp2
1970 reg2 = registerName register2 tmp2
1971 code__2 = code1 `appOL` code2
1973 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1977 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1979 code = unitOL (SETHI (HI imm__2) tmp)
1981 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1984 imm__2 = case imm of Just x -> x
1987 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1988 getRegister other `thenNat` \ register ->
1990 code = registerCode register tmp
1991 reg = registerName register tmp
1994 returnNat (Amode (AddrRegImm reg off) code)
1996 #endif {- sparc_TARGET_ARCH -}
1998 #ifdef powerpc_TARGET_ARCH
1999 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
2001 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2002 getRegister x `thenNat` \ register ->
2004 code = registerCode register tmp
2005 reg = registerName register tmp
2006 off = ImmInt (-(fromInteger i))
2008 returnNat (Amode (AddrRegImm reg off) code)
2011 getAmode (StMachOp MO_Nat_Add [x, StInt i])
2013 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2014 getRegister x `thenNat` \ register ->
2016 code = registerCode register tmp
2017 reg = registerName register tmp
2018 off = ImmInt (fromInteger i)
2020 returnNat (Amode (AddrRegImm reg off) code)
2024 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2026 code = unitOL (LIS tmp (HA imm__2))
2028 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
2031 imm__2 = case imm of Just x -> x
2034 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2035 getRegister other `thenNat` \ register ->
2037 code = registerCode register tmp
2038 reg = registerName register tmp
2041 returnNat (Amode (AddrRegImm reg off) code)
2042 #endif {- powerpc_TARGET_ARCH -}
2044 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2047 %************************************************************************
2049 \subsection{The @CondCode@ type}
2051 %************************************************************************
2053 Condition codes passed up the tree.
2055 data CondCode = CondCode Bool Cond InstrBlock
2057 condName (CondCode _ cond _) = cond
2058 condFloat (CondCode is_float _ _) = is_float
2059 condCode (CondCode _ _ code) = code
2062 Set up a condition code for a conditional branch.
2065 getCondCode :: StixExpr -> NatM CondCode
2067 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2069 #if alpha_TARGET_ARCH
2070 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2071 #endif {- alpha_TARGET_ARCH -}
2073 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2075 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2076 -- yes, they really do seem to want exactly the same!
2078 getCondCode (StMachOp mop [x, y])
2080 MO_32U_Gt -> condIntCode GTT x y
2081 MO_32U_Ge -> condIntCode GE x y
2082 MO_32U_Eq -> condIntCode EQQ x y
2083 MO_32U_Ne -> condIntCode NE x y
2084 MO_32U_Lt -> condIntCode LTT x y
2085 MO_32U_Le -> condIntCode LE x y
2087 MO_Nat_Eq -> condIntCode EQQ x y
2088 MO_Nat_Ne -> condIntCode NE x y
2090 MO_NatS_Gt -> condIntCode GTT x y
2091 MO_NatS_Ge -> condIntCode GE x y
2092 MO_NatS_Lt -> condIntCode LTT x y
2093 MO_NatS_Le -> condIntCode LE x y
2095 MO_NatU_Gt -> condIntCode GU x y
2096 MO_NatU_Ge -> condIntCode GEU x y
2097 MO_NatU_Lt -> condIntCode LU x y
2098 MO_NatU_Le -> condIntCode LEU x y
2100 MO_Flt_Gt -> condFltCode GTT x y
2101 MO_Flt_Ge -> condFltCode GE x y
2102 MO_Flt_Eq -> condFltCode EQQ x y
2103 MO_Flt_Ne -> condFltCode NE x y
2104 MO_Flt_Lt -> condFltCode LTT x y
2105 MO_Flt_Le -> condFltCode LE x y
2107 MO_Dbl_Gt -> condFltCode GTT x y
2108 MO_Dbl_Ge -> condFltCode GE x y
2109 MO_Dbl_Eq -> condFltCode EQQ x y
2110 MO_Dbl_Ne -> condFltCode NE x y
2111 MO_Dbl_Lt -> condFltCode LTT x y
2112 MO_Dbl_Le -> condFltCode LE x y
2114 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2116 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2118 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH -}
2121 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2126 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2127 passed back up the tree.
2130 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2132 #if alpha_TARGET_ARCH
2133 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2134 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2135 #endif {- alpha_TARGET_ARCH -}
2137 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2138 #if i386_TARGET_ARCH
2140 -- memory vs immediate
2141 condIntCode cond (StInd pk x) y
2142 | Just i <- maybeImm y
2143 = getAmode x `thenNat` \ amode ->
2145 code1 = amodeCode amode
2146 x__2 = amodeAddr amode
2147 sz = primRepToSize pk
2148 code__2 = code1 `snocOL`
2149 CMP sz (OpImm i) (OpAddr x__2)
2151 returnNat (CondCode False cond code__2)
2154 condIntCode cond x (StInt 0)
2155 = getRegister x `thenNat` \ register1 ->
2156 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2158 code1 = registerCode register1 tmp1
2159 src1 = registerName register1 tmp1
2160 code__2 = code1 `snocOL`
2161 TEST L (OpReg src1) (OpReg src1)
2163 returnNat (CondCode False cond code__2)
2165 -- anything vs immediate
2166 condIntCode cond x y
2167 | Just i <- maybeImm y
2168 = getRegister x `thenNat` \ register1 ->
2169 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2171 code1 = registerCode register1 tmp1
2172 src1 = registerName register1 tmp1
2173 code__2 = code1 `snocOL`
2174 CMP L (OpImm i) (OpReg src1)
2176 returnNat (CondCode False cond code__2)
2178 -- memory vs anything
2179 condIntCode cond (StInd pk x) y
2180 = getAmode x `thenNat` \ amode_x ->
2181 getRegister y `thenNat` \ reg_y ->
2182 getNewRegNCG IntRep `thenNat` \ tmp ->
2184 c_x = amodeCode amode_x
2185 am_x = amodeAddr amode_x
2186 c_y = registerCode reg_y tmp
2187 r_y = registerName reg_y tmp
2188 sz = primRepToSize pk
2190 -- optimisation: if there's no code for x, just an amode,
2191 -- use whatever reg y winds up in. Assumes that c_y doesn't
2192 -- clobber any regs in the amode am_x, which I'm not sure is
2193 -- justified. The otherwise clause makes the same assumption.
2194 code__2 | isNilOL c_x
2196 CMP sz (OpReg r_y) (OpAddr am_x)
2200 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2202 CMP sz (OpReg tmp) (OpAddr am_x)
2204 returnNat (CondCode False cond code__2)
2206 -- anything vs memory
2208 condIntCode cond y (StInd pk x)
2209 = getAmode x `thenNat` \ amode_x ->
2210 getRegister y `thenNat` \ reg_y ->
2211 getNewRegNCG IntRep `thenNat` \ tmp ->
2213 c_x = amodeCode amode_x
2214 am_x = amodeAddr amode_x
2215 c_y = registerCode reg_y tmp
2216 r_y = registerName reg_y tmp
2217 sz = primRepToSize pk
2218 -- same optimisation and nagging doubts as previous clause
2219 code__2 | isNilOL c_x
2221 CMP sz (OpAddr am_x) (OpReg r_y)
2225 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2227 CMP sz (OpAddr am_x) (OpReg tmp)
2229 returnNat (CondCode False cond code__2)
2231 -- anything vs anything
2232 condIntCode cond x y
2233 = getRegister x `thenNat` \ register1 ->
2234 getRegister y `thenNat` \ register2 ->
2235 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2236 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2238 code1 = registerCode register1 tmp1
2239 src1 = registerName register1 tmp1
2240 code2 = registerCode register2 tmp2
2241 src2 = registerName register2 tmp2
2242 code__2 = code1 `snocOL`
2243 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2245 CMP L (OpReg src2) (OpReg tmp1)
2247 returnNat (CondCode False cond code__2)
2250 condFltCode cond x y
2251 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2252 getRegister x `thenNat` \ register1 ->
2253 getRegister y `thenNat` \ register2 ->
2254 getNewRegNCG (registerRep register1)
2256 getNewRegNCG (registerRep register2)
2258 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2260 code1 = registerCode register1 tmp1
2261 src1 = registerName register1 tmp1
2263 code2 = registerCode register2 tmp2
2264 src2 = registerName register2 tmp2
2266 code__2 | isAny register1
2267 = code1 `appOL` -- result in tmp1
2273 GMOV src1 tmp1 `appOL`
2277 -- The GCMP insn does the test and sets the zero flag if comparable
2278 -- and true. Hence we always supply EQQ as the condition to test.
2279 returnNat (CondCode True EQQ code__2)
2281 #endif {- i386_TARGET_ARCH -}
2283 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2285 #if sparc_TARGET_ARCH
2287 condIntCode cond x (StInt y)
2289 = getRegister x `thenNat` \ register ->
2290 getNewRegNCG IntRep `thenNat` \ tmp ->
2292 code = registerCode register tmp
2293 src1 = registerName register tmp
2294 src2 = ImmInt (fromInteger y)
2295 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2297 returnNat (CondCode False cond code__2)
2299 condIntCode cond x y
2300 = getRegister x `thenNat` \ register1 ->
2301 getRegister y `thenNat` \ register2 ->
2302 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2303 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2305 code1 = registerCode register1 tmp1
2306 src1 = registerName register1 tmp1
2307 code2 = registerCode register2 tmp2
2308 src2 = registerName register2 tmp2
2309 code__2 = code1 `appOL` code2 `snocOL`
2310 SUB False True src1 (RIReg src2) g0
2312 returnNat (CondCode False cond code__2)
2315 condFltCode cond x y
2316 = getRegister x `thenNat` \ register1 ->
2317 getRegister y `thenNat` \ register2 ->
2318 getNewRegNCG (registerRep register1)
2320 getNewRegNCG (registerRep register2)
2322 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2324 promote x = FxTOy F DF x tmp
2326 pk1 = registerRep register1
2327 code1 = registerCode register1 tmp1
2328 src1 = registerName register1 tmp1
2330 pk2 = registerRep register2
2331 code2 = registerCode register2 tmp2
2332 src2 = registerName register2 tmp2
2336 code1 `appOL` code2 `snocOL`
2337 FCMP True (primRepToSize pk1) src1 src2
2338 else if pk1 == FloatRep then
2339 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2340 FCMP True DF tmp src2
2342 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2343 FCMP True DF src1 tmp
2345 returnNat (CondCode True cond code__2)
2347 #endif {- sparc_TARGET_ARCH -}
2349 #if powerpc_TARGET_ARCH
2351 condIntCode cond x (StInt y)
2353 = getRegister x `thenNat` \ register ->
2354 getNewRegNCG IntRep `thenNat` \ tmp ->
2356 code = registerCode register tmp
2357 src1 = registerName register tmp
2358 src2 = ImmInt (fromInteger y)
2359 code__2 = code `snocOL`
2360 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2362 returnNat (CondCode False cond code__2)
2364 condIntCode cond x y
2365 = getRegister x `thenNat` \ register1 ->
2366 getRegister y `thenNat` \ register2 ->
2367 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2368 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2370 code1 = registerCode register1 tmp1
2371 src1 = registerName register1 tmp1
2372 code2 = registerCode register2 tmp2
2373 src2 = registerName register2 tmp2
2374 code__2 = code1 `appOL` code2 `snocOL`
2375 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2377 returnNat (CondCode False cond code__2)
2379 condFltCode cond x y
2380 = getRegister x `thenNat` \ register1 ->
2381 getRegister y `thenNat` \ register2 ->
2382 getNewRegNCG (registerRep register1)
2384 getNewRegNCG (registerRep register2)
2387 code1 = registerCode register1 tmp1
2388 src1 = registerName register1 tmp1
2389 code2 = registerCode register2 tmp2
2390 src2 = registerName register2 tmp2
2391 code__2 = code1 `appOL` code2 `snocOL`
2394 returnNat (CondCode False cond code__2)
2396 #endif {- powerpc_TARGET_ARCH -}
2399 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2402 %************************************************************************
2404 \subsection{Generating assignments}
2406 %************************************************************************
2408 Assignments are really at the heart of the whole code generation
2409 business. Almost all top-level nodes of any real importance are
2410 assignments, which correspond to loads, stores, or register transfers.
2411 If we're really lucky, some of the register transfers will go away,
2412 because we can use the destination register to complete the code
2413 generation for the right hand side. This only fails when the right
2414 hand side is forced into a fixed register (e.g. the result of a call).
2417 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2418 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2420 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2421 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2423 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2425 #if alpha_TARGET_ARCH
2427 assignIntCode pk (StInd _ dst) src
2428 = getNewRegNCG IntRep `thenNat` \ tmp ->
2429 getAmode dst `thenNat` \ amode ->
2430 getRegister src `thenNat` \ register ->
2432 code1 = amodeCode amode []
2433 dst__2 = amodeAddr amode
2434 code2 = registerCode register tmp []
2435 src__2 = registerName register tmp
2436 sz = primRepToSize pk
2437 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2441 assignIntCode pk dst src
2442 = getRegister dst `thenNat` \ register1 ->
2443 getRegister src `thenNat` \ register2 ->
2445 dst__2 = registerName register1 zeroh
2446 code = registerCode register2 dst__2
2447 src__2 = registerName register2 dst__2
2448 code__2 = if isFixed register2
2449 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2454 #endif {- alpha_TARGET_ARCH -}
2456 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2458 #if i386_TARGET_ARCH
2460 -- non-FP assignment to memory
2461 assignMem_IntCode pk addr src
2462 = getAmode addr `thenNat` \ amode ->
2463 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2464 getNewRegNCG PtrRep `thenNat` \ tmp ->
2466 -- In general, if the address computation for dst may require
2467 -- some insns preceding the addressing mode itself. So there's
2468 -- no guarantee that the code for dst and the code for src won't
2469 -- write the same register. This means either the address or
2470 -- the value needs to be copied into a temporary. We detect the
2471 -- common case where the amode has no code, and elide the copy.
2472 codea = amodeCode amode
2473 dst__a = amodeAddr amode
2475 code | isNilOL codea
2477 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2480 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2482 MOV (primRepToSize pk) opsrc
2483 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2489 -> NatM (InstrBlock,Operand) -- code, operator
2492 | Just x <- maybeImm op
2493 = returnNat (nilOL, OpImm x)
2496 = getRegister op `thenNat` \ register ->
2497 getNewRegNCG (registerRep register)
2499 let code = registerCode register tmp
2500 reg = registerName register tmp
2502 returnNat (code, OpReg reg)
2504 -- Assign; dst is a reg, rhs is mem
2505 assignReg_IntCode pk reg (StInd pks src)
2506 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2507 getAmode src `thenNat` \ amode ->
2508 getRegisterReg reg `thenNat` \ reg_dst ->
2510 c_addr = amodeCode amode
2511 am_addr = amodeAddr amode
2512 r_dst = registerName reg_dst tmp
2513 szs = primRepToSize pks
2522 code = c_addr `snocOL`
2523 opc (OpAddr am_addr) (OpReg r_dst)
2527 -- dst is a reg, but src could be anything
2528 assignReg_IntCode pk reg src
2529 = getRegisterReg reg `thenNat` \ registerd ->
2530 getRegister src `thenNat` \ registers ->
2531 getNewRegNCG IntRep `thenNat` \ tmp ->
2533 r_dst = registerName registerd tmp
2534 r_src = registerName registers r_dst
2535 c_src = registerCode registers r_dst
2537 code = c_src `snocOL`
2538 MOV L (OpReg r_src) (OpReg r_dst)
2542 #endif {- i386_TARGET_ARCH -}
2544 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2546 #if sparc_TARGET_ARCH
2548 assignMem_IntCode pk addr src
2549 = getNewRegNCG IntRep `thenNat` \ tmp ->
2550 getAmode addr `thenNat` \ amode ->
2551 getRegister src `thenNat` \ register ->
2553 code1 = amodeCode amode
2554 dst__2 = amodeAddr amode
2555 code2 = registerCode register tmp
2556 src__2 = registerName register tmp
2557 sz = primRepToSize pk
2558 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2562 assignReg_IntCode pk reg src
2563 = getRegister src `thenNat` \ register2 ->
2564 getRegisterReg reg `thenNat` \ register1 ->
2565 getNewRegNCG IntRep `thenNat` \ tmp ->
2567 dst__2 = registerName register1 tmp
2568 code = registerCode register2 dst__2
2569 src__2 = registerName register2 dst__2
2570 code__2 = if isFixed register2
2571 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2576 #endif {- sparc_TARGET_ARCH -}
2578 #if powerpc_TARGET_ARCH
2580 assignMem_IntCode pk addr src
2581 = getNewRegNCG IntRep `thenNat` \ tmp ->
2582 getAmode addr `thenNat` \ amode ->
2583 getRegister src `thenNat` \ register ->
2585 code1 = amodeCode amode
2586 dst__2 = amodeAddr amode
2587 code2 = registerCode register tmp
2588 src__2 = registerName register tmp
2589 sz = primRepToSize pk
2590 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2594 assignReg_IntCode pk reg src
2595 = getRegister src `thenNat` \ register2 ->
2596 getRegisterReg reg `thenNat` \ register1 ->
2598 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2599 code = registerCode register2 dst__2
2600 src__2 = registerName register2 dst__2
2601 code__2 = if isFixed register2
2602 then code `snocOL` MR dst__2 src__2
2607 #endif {- powerpc_TARGET_ARCH -}
2609 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2612 % --------------------------------
2613 Floating-point assignments:
2614 % --------------------------------
2617 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2618 #if alpha_TARGET_ARCH
2620 assignFltCode pk (StInd _ dst) src
2621 = getNewRegNCG pk `thenNat` \ tmp ->
2622 getAmode dst `thenNat` \ amode ->
2623 getRegister src `thenNat` \ register ->
2625 code1 = amodeCode amode []
2626 dst__2 = amodeAddr amode
2627 code2 = registerCode register tmp []
2628 src__2 = registerName register tmp
2629 sz = primRepToSize pk
2630 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2634 assignFltCode pk dst src
2635 = getRegister dst `thenNat` \ register1 ->
2636 getRegister src `thenNat` \ register2 ->
2638 dst__2 = registerName register1 zeroh
2639 code = registerCode register2 dst__2
2640 src__2 = registerName register2 dst__2
2641 code__2 = if isFixed register2
2642 then code . mkSeqInstr (FMOV src__2 dst__2)
2647 #endif {- alpha_TARGET_ARCH -}
2649 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2651 #if i386_TARGET_ARCH
2653 -- Floating point assignment to memory
2654 assignMem_FltCode pk addr src
2655 = getRegister src `thenNat` \ reg_src ->
2656 getRegister addr `thenNat` \ reg_addr ->
2657 getNewRegNCG pk `thenNat` \ tmp_src ->
2658 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2659 let r_src = registerName reg_src tmp_src
2660 c_src = registerCode reg_src tmp_src
2661 r_addr = registerName reg_addr tmp_addr
2662 c_addr = registerCode reg_addr tmp_addr
2663 sz = primRepToSize pk
2665 code = c_src `appOL`
2666 -- no need to preserve r_src across the addr computation,
2667 -- since r_src must be a float reg
2668 -- whilst r_addr is an int reg
2671 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2675 -- Floating point assignment to a register/temporary
2676 assignReg_FltCode pk reg src
2677 = getRegisterReg reg `thenNat` \ reg_dst ->
2678 getRegister src `thenNat` \ reg_src ->
2679 getNewRegNCG pk `thenNat` \ tmp ->
2681 r_dst = registerName reg_dst tmp
2682 r_src = registerName reg_src r_dst
2683 c_src = registerCode reg_src r_dst
2685 code = if isFixed reg_src
2686 then c_src `snocOL` GMOV r_src r_dst
2692 #endif {- i386_TARGET_ARCH -}
2694 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2696 #if sparc_TARGET_ARCH
2698 -- Floating point assignment to memory
2699 assignMem_FltCode pk addr src
2700 = getNewRegNCG pk `thenNat` \ tmp1 ->
2701 getAmode addr `thenNat` \ amode ->
2702 getRegister src `thenNat` \ register ->
2704 sz = primRepToSize pk
2705 dst__2 = amodeAddr amode
2707 code1 = amodeCode amode
2708 code2 = registerCode register tmp1
2710 src__2 = registerName register tmp1
2711 pk__2 = registerRep register
2712 sz__2 = primRepToSize pk__2
2714 code__2 = code1 `appOL` code2 `appOL`
2716 then unitOL (ST sz src__2 dst__2)
2717 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2721 -- Floating point assignment to a register/temporary
2722 -- Why is this so bizarrely ugly?
2723 assignReg_FltCode pk reg src
2724 = getRegisterReg reg `thenNat` \ register1 ->
2725 getRegister src `thenNat` \ register2 ->
2727 pk__2 = registerRep register2
2728 sz__2 = primRepToSize pk__2
2730 getNewRegNCG pk__2 `thenNat` \ tmp ->
2732 sz = primRepToSize pk
2733 dst__2 = registerName register1 g0 -- must be Fixed
2734 reg__2 = if pk /= pk__2 then tmp else dst__2
2735 code = registerCode register2 reg__2
2736 src__2 = registerName register2 reg__2
2739 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2740 else if isFixed register2 then
2741 code `snocOL` FMOV sz src__2 dst__2
2747 #endif {- sparc_TARGET_ARCH -}
2749 #if powerpc_TARGET_ARCH
2751 -- Floating point assignment to memory
2752 assignMem_FltCode pk addr src
2753 = getNewRegNCG pk `thenNat` \ tmp1 ->
2754 getAmode addr `thenNat` \ amode ->
2755 getRegister src `thenNat` \ register ->
2757 sz = primRepToSize pk
2758 dst__2 = amodeAddr amode
2760 code1 = amodeCode amode
2761 code2 = registerCode register tmp1
2763 src__2 = registerName register tmp1
2764 pk__2 = registerRep register
2766 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2770 -- Floating point assignment to a register/temporary
2771 assignReg_FltCode pk reg src
2772 = getRegisterReg reg `thenNat` \ reg_dst ->
2773 getRegister src `thenNat` \ reg_src ->
2774 getNewRegNCG pk `thenNat` \ tmp ->
2776 r_dst = registerName reg_dst tmp
2777 r_src = registerName reg_src r_dst
2778 c_src = registerCode reg_src r_dst
2780 code = if isFixed reg_src
2781 then c_src `snocOL` MR r_dst r_src
2785 #endif {- powerpc_TARGET_ARCH -}
2787 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2790 %************************************************************************
2792 \subsection{Generating an unconditional branch}
2794 %************************************************************************
2796 We accept two types of targets: an immediate CLabel or a tree that
2797 gets evaluated into a register. Any CLabels which are AsmTemporaries
2798 are assumed to be in the local block of code, close enough for a
2799 branch instruction. Other CLabels are assumed to be far away.
2801 (If applicable) Do not fill the delay slots here; you will confuse the
2805 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2807 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2809 #if alpha_TARGET_ARCH
2811 genJump (StCLbl lbl)
2812 | isAsmTemp lbl = returnInstr (BR target)
2813 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2815 target = ImmCLbl lbl
2818 = getRegister tree `thenNat` \ register ->
2819 getNewRegNCG PtrRep `thenNat` \ tmp ->
2821 dst = registerName register pv
2822 code = registerCode register pv
2823 target = registerName register pv
2825 if isFixed register then
2826 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2828 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2830 #endif {- alpha_TARGET_ARCH -}
2832 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2834 #if i386_TARGET_ARCH
2836 genJump dsts (StInd pk mem)
2837 = getAmode mem `thenNat` \ amode ->
2839 code = amodeCode amode
2840 target = amodeAddr amode
2842 returnNat (code `snocOL` JMP dsts (OpAddr target))
2846 = returnNat (unitOL (JMP dsts (OpImm target)))
2849 = getRegister tree `thenNat` \ register ->
2850 getNewRegNCG PtrRep `thenNat` \ tmp ->
2852 code = registerCode register tmp
2853 target = registerName register tmp
2855 returnNat (code `snocOL` JMP dsts (OpReg target))
2858 target = case imm of Just x -> x
2860 #endif {- i386_TARGET_ARCH -}
2862 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2864 #if sparc_TARGET_ARCH
2866 genJump dsts (StCLbl lbl)
2867 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2868 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2869 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2871 target = ImmCLbl lbl
2874 = getRegister tree `thenNat` \ register ->
2875 getNewRegNCG PtrRep `thenNat` \ tmp ->
2877 code = registerCode register tmp
2878 target = registerName register tmp
2880 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2882 #endif {- sparc_TARGET_ARCH -}
2884 #if powerpc_TARGET_ARCH
2885 genJump dsts (StCLbl lbl)
2886 = returnNat (toOL [BCC ALWAYS lbl])
2889 = getRegister tree `thenNat` \ register ->
2890 getNewRegNCG PtrRep `thenNat` \ tmp ->
2892 code = registerCode register tmp
2893 target = registerName register tmp
2895 returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
2896 #endif {- sparc_TARGET_ARCH -}
2898 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2903 %************************************************************************
2905 \subsection{Conditional jumps}
2907 %************************************************************************
2909 Conditional jumps are always to local labels, so we can use branch
2910 instructions. We peek at the arguments to decide what kind of
2913 ALPHA: For comparisons with 0, we're laughing, because we can just do
2914 the desired conditional branch.
2916 I386: First, we have to ensure that the condition
2917 codes are set according to the supplied comparison operation.
2919 SPARC: First, we have to ensure that the condition codes are set
2920 according to the supplied comparison operation. We generate slightly
2921 different code for floating point comparisons, because a floating
2922 point operation cannot directly precede a @BF@. We assume the worst
2923 and fill that slot with a @NOP@.
2925 SPARC: Do not fill the delay slots here; you will confuse the register
2930 :: CLabel -- the branch target
2931 -> StixExpr -- the condition on which to branch
2934 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2936 #if alpha_TARGET_ARCH
2938 genCondJump lbl (StPrim op [x, StInt 0])
2939 = getRegister x `thenNat` \ register ->
2940 getNewRegNCG (registerRep register)
2943 code = registerCode register tmp
2944 value = registerName register tmp
2945 pk = registerRep register
2946 target = ImmCLbl lbl
2948 returnSeq code [BI (cmpOp op) value target]
2950 cmpOp CharGtOp = GTT
2952 cmpOp CharEqOp = EQQ
2954 cmpOp CharLtOp = LTT
2963 cmpOp WordGeOp = ALWAYS
2964 cmpOp WordEqOp = EQQ
2966 cmpOp WordLtOp = NEVER
2967 cmpOp WordLeOp = EQQ
2969 cmpOp AddrGeOp = ALWAYS
2970 cmpOp AddrEqOp = EQQ
2972 cmpOp AddrLtOp = NEVER
2973 cmpOp AddrLeOp = EQQ
2975 genCondJump lbl (StPrim op [x, StDouble 0.0])
2976 = getRegister x `thenNat` \ register ->
2977 getNewRegNCG (registerRep register)
2980 code = registerCode register tmp
2981 value = registerName register tmp
2982 pk = registerRep register
2983 target = ImmCLbl lbl
2985 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2987 cmpOp FloatGtOp = GTT
2988 cmpOp FloatGeOp = GE
2989 cmpOp FloatEqOp = EQQ
2990 cmpOp FloatNeOp = NE
2991 cmpOp FloatLtOp = LTT
2992 cmpOp FloatLeOp = LE
2993 cmpOp DoubleGtOp = GTT
2994 cmpOp DoubleGeOp = GE
2995 cmpOp DoubleEqOp = EQQ
2996 cmpOp DoubleNeOp = NE
2997 cmpOp DoubleLtOp = LTT
2998 cmpOp DoubleLeOp = LE
3000 genCondJump lbl (StPrim op [x, y])
3002 = trivialFCode pr instr x y `thenNat` \ register ->
3003 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3005 code = registerCode register tmp
3006 result = registerName register tmp
3007 target = ImmCLbl lbl
3009 returnNat (code . mkSeqInstr (BF cond result target))
3011 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
3013 fltCmpOp op = case op of
3027 (instr, cond) = case op of
3028 FloatGtOp -> (FCMP TF LE, EQQ)
3029 FloatGeOp -> (FCMP TF LTT, EQQ)
3030 FloatEqOp -> (FCMP TF EQQ, NE)
3031 FloatNeOp -> (FCMP TF EQQ, EQQ)
3032 FloatLtOp -> (FCMP TF LTT, NE)
3033 FloatLeOp -> (FCMP TF LE, NE)
3034 DoubleGtOp -> (FCMP TF LE, EQQ)
3035 DoubleGeOp -> (FCMP TF LTT, EQQ)
3036 DoubleEqOp -> (FCMP TF EQQ, NE)
3037 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3038 DoubleLtOp -> (FCMP TF LTT, NE)
3039 DoubleLeOp -> (FCMP TF LE, NE)
3041 genCondJump lbl (StPrim op [x, y])
3042 = trivialCode instr x y `thenNat` \ register ->
3043 getNewRegNCG IntRep `thenNat` \ tmp ->
3045 code = registerCode register tmp
3046 result = registerName register tmp
3047 target = ImmCLbl lbl
3049 returnNat (code . mkSeqInstr (BI cond result target))
3051 (instr, cond) = case op of
3052 CharGtOp -> (CMP LE, EQQ)
3053 CharGeOp -> (CMP LTT, EQQ)
3054 CharEqOp -> (CMP EQQ, NE)
3055 CharNeOp -> (CMP EQQ, EQQ)
3056 CharLtOp -> (CMP LTT, NE)
3057 CharLeOp -> (CMP LE, NE)
3058 IntGtOp -> (CMP LE, EQQ)
3059 IntGeOp -> (CMP LTT, EQQ)
3060 IntEqOp -> (CMP EQQ, NE)
3061 IntNeOp -> (CMP EQQ, EQQ)
3062 IntLtOp -> (CMP LTT, NE)
3063 IntLeOp -> (CMP LE, NE)
3064 WordGtOp -> (CMP ULE, EQQ)
3065 WordGeOp -> (CMP ULT, EQQ)
3066 WordEqOp -> (CMP EQQ, NE)
3067 WordNeOp -> (CMP EQQ, EQQ)
3068 WordLtOp -> (CMP ULT, NE)
3069 WordLeOp -> (CMP ULE, NE)
3070 AddrGtOp -> (CMP ULE, EQQ)
3071 AddrGeOp -> (CMP ULT, EQQ)
3072 AddrEqOp -> (CMP EQQ, NE)
3073 AddrNeOp -> (CMP EQQ, EQQ)
3074 AddrLtOp -> (CMP ULT, NE)
3075 AddrLeOp -> (CMP ULE, NE)
3077 #endif {- alpha_TARGET_ARCH -}
3079 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3081 #if i386_TARGET_ARCH
3083 genCondJump lbl bool
3084 = getCondCode bool `thenNat` \ condition ->
3086 code = condCode condition
3087 cond = condName condition
3089 returnNat (code `snocOL` JXX cond lbl)
3091 #endif {- i386_TARGET_ARCH -}
3093 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3095 #if sparc_TARGET_ARCH
3097 genCondJump lbl bool
3098 = getCondCode bool `thenNat` \ condition ->
3100 code = condCode condition
3101 cond = condName condition
3102 target = ImmCLbl lbl
3107 if condFloat condition
3108 then [NOP, BF cond False target, NOP]
3109 else [BI cond False target, NOP]
3113 #endif {- sparc_TARGET_ARCH -}
3115 #if powerpc_TARGET_ARCH
3117 genCondJump lbl bool
3118 = getCondCode bool `thenNat` \ condition ->
3120 code = condCode condition
3121 cond = condName condition
3122 target = ImmCLbl lbl
3125 code `snocOL` BCC cond lbl )
3127 #endif {- powerpc_TARGET_ARCH -}
3129 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3131 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3134 %************************************************************************
3136 \subsection{Generating C calls}
3138 %************************************************************************
3140 Now the biggest nightmare---calls. Most of the nastiness is buried in
3141 @get_arg@, which moves the arguments to the correct registers/stack
3142 locations. Apart from that, the code is easy.
3144 (If applicable) Do not fill the delay slots here; you will confuse the
3149 :: (Either FastString StixExpr) -- function to call
3151 -> PrimRep -- type of the result
3152 -> [StixExpr] -- arguments (of mixed type)
3155 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3157 #if alpha_TARGET_ARCH
3159 genCCall fn cconv kind args
3160 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3161 `thenNat` \ ((unused,_), argCode) ->
3163 nRegs = length allArgRegs - length unused
3164 code = asmSeqThen (map ($ []) argCode)
3167 LDA pv (AddrImm (ImmLab (ptext fn))),
3168 JSR ra (AddrReg pv) nRegs,
3169 LDGP gp (AddrReg ra)]
3171 ------------------------
3172 {- Try to get a value into a specific register (or registers) for
3173 a call. The first 6 arguments go into the appropriate
3174 argument register (separate registers for integer and floating
3175 point arguments, but used in lock-step), and the remaining
3176 arguments are dumped to the stack, beginning at 0(sp). Our
3177 first argument is a pair of the list of remaining argument
3178 registers to be assigned for this call and the next stack
3179 offset to use for overflowing arguments. This way,
3180 @get_Arg@ can be applied to all of a call's arguments using
3184 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3185 -> StixTree -- Current argument
3186 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3188 -- We have to use up all of our argument registers first...
3190 get_arg ((iDst,fDst):dsts, offset) arg
3191 = getRegister arg `thenNat` \ register ->
3193 reg = if isFloatingRep pk then fDst else iDst
3194 code = registerCode register reg
3195 src = registerName register reg
3196 pk = registerRep register
3199 if isFloatingRep pk then
3200 ((dsts, offset), if isFixed register then
3201 code . mkSeqInstr (FMOV src fDst)
3204 ((dsts, offset), if isFixed register then
3205 code . mkSeqInstr (OR src (RIReg src) iDst)
3208 -- Once we have run out of argument registers, we move to the
3211 get_arg ([], offset) arg
3212 = getRegister arg `thenNat` \ register ->
3213 getNewRegNCG (registerRep register)
3216 code = registerCode register tmp
3217 src = registerName register tmp
3218 pk = registerRep register
3219 sz = primRepToSize pk
3221 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3223 #endif {- alpha_TARGET_ARCH -}
3225 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3227 #if i386_TARGET_ARCH
3229 genCCall fn cconv ret_rep args
3231 (reverse args) `thenNat` \ sizes_n_codes ->
3232 getDeltaNat `thenNat` \ delta ->
3233 let (sizes, push_codes) = unzip sizes_n_codes
3234 tot_arg_size = sum sizes
3236 -- deal with static vs dynamic call targets
3239 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3241 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3242 ASSERT(case dyn_rep of { L -> True; _ -> False})
3243 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3245 `thenNat` \ callinsns ->
3246 let push_code = concatOL push_codes
3247 call = callinsns `appOL`
3249 -- Deallocate parameters after call for ccall;
3250 -- but not for stdcall (callee does it)
3251 (if cconv == StdCallConv then [] else
3252 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3254 [DELTA (delta + tot_arg_size)]
3257 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3258 returnNat (push_code `appOL` call)
3261 -- function names that begin with '.' are assumed to be special
3262 -- internally generated names like '.mul,' which don't get an
3263 -- underscore prefix
3264 -- ToDo:needed (WDP 96/03) ???
3265 fn_u = unpackFS (unLeft fn)
3268 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3269 | otherwise -- General case
3270 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3272 stdcallsize tot_arg_size
3273 | cconv == StdCallConv = '@':show tot_arg_size
3281 push_arg :: StixExpr{-current argument-}
3282 -> NatM (Int, InstrBlock) -- argsz, code
3285 | is64BitRep arg_rep
3286 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3287 getDeltaNat `thenNat` \ delta ->
3288 setDeltaNat (delta - 8) `thenNat` \ _ ->
3289 let r_lo = VirtualRegI vr_lo
3290 r_hi = getHiVRegFromLo r_lo
3293 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3294 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3297 = get_op arg `thenNat` \ (code, reg, sz) ->
3298 getDeltaNat `thenNat` \ delta ->
3299 arg_size sz `bind` \ size ->
3300 setDeltaNat (delta-size) `thenNat` \ _ ->
3301 if (case sz of DF -> True; F -> True; _ -> False)
3302 then returnNat (size,
3304 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3306 GST sz reg (AddrBaseIndex (Just esp)
3310 else returnNat (size,
3312 PUSH L (OpReg reg) `snocOL`
3316 arg_rep = repOfStixExpr arg
3321 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3324 = getRegister op `thenNat` \ register ->
3325 getNewRegNCG (registerRep register)
3328 code = registerCode register tmp
3329 reg = registerName register tmp
3330 pk = registerRep register
3331 sz = primRepToSize pk
3333 returnNat (code, reg, sz)
3335 #endif {- i386_TARGET_ARCH -}
3337 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3339 #if sparc_TARGET_ARCH
3341 The SPARC calling convention is an absolute
3342 nightmare. The first 6x32 bits of arguments are mapped into
3343 %o0 through %o5, and the remaining arguments are dumped to the
3344 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3346 If we have to put args on the stack, move %o6==%sp down by
3347 the number of words to go on the stack, to ensure there's enough space.
3349 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3350 16 words above the stack pointer is a word for the address of
3351 a structure return value. I use this as a temporary location
3352 for moving values from float to int regs. Certainly it isn't
3353 safe to put anything in the 16 words starting at %sp, since
3354 this area can get trashed at any time due to window overflows
3355 caused by signal handlers.
3357 A final complication (if the above isn't enough) is that
3358 we can't blithely calculate the arguments one by one into
3359 %o0 .. %o5. Consider the following nested calls:
3363 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3364 the inner call will itself use %o0, which trashes the value put there
3365 in preparation for the outer call. Upshot: we need to calculate the
3366 args into temporary regs, and move those to arg regs or onto the
3367 stack only immediately prior to the call proper. Sigh.
3370 genCCall fn cconv kind args
3371 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3373 (argcodes, vregss) = unzip argcode_and_vregs
3374 n_argRegs = length allArgRegs
3375 n_argRegs_used = min (length vregs) n_argRegs
3376 vregs = concat vregss
3378 -- deal with static vs dynamic call targets
3381 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3383 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3384 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3386 `thenNat` \ callinsns ->
3388 argcode = concatOL argcodes
3389 (move_sp_down, move_sp_up)
3390 = let diff = length vregs - n_argRegs
3391 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3394 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3396 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3398 returnNat (argcode `appOL`
3399 move_sp_down `appOL`
3400 transfer_code `appOL`
3405 -- function names that begin with '.' are assumed to be special
3406 -- internally generated names like '.mul,' which don't get an
3407 -- underscore prefix
3408 -- ToDo:needed (WDP 96/03) ???
3409 fn_static = unLeft fn
3410 fn__2 = case (headFS fn_static) of
3411 '.' -> ImmLit (ftext fn_static)
3412 _ -> ImmLab False (ftext fn_static)
3414 -- move args from the integer vregs into which they have been
3415 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3416 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3418 move_final [] _ offset -- all args done
3421 move_final (v:vs) [] offset -- out of aregs; move to stack
3422 = ST W v (spRel offset)
3423 : move_final vs [] (offset+1)
3425 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3426 = OR False g0 (RIReg v) a
3427 : move_final vs az offset
3429 -- generate code to calculate an argument, and move it into one
3430 -- or two integer vregs.
3431 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3432 arg_to_int_vregs arg
3433 | is64BitRep (repOfStixExpr arg)
3434 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3435 let r_lo = VirtualRegI vr_lo
3436 r_hi = getHiVRegFromLo r_lo
3437 in returnNat (code, [r_hi, r_lo])
3439 = getRegister arg `thenNat` \ register ->
3440 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3441 let code = registerCode register tmp
3442 src = registerName register tmp
3443 pk = registerRep register
3445 -- the value is in src. Get it into 1 or 2 int vregs.
3448 getNewRegNCG WordRep `thenNat` \ v1 ->
3449 getNewRegNCG WordRep `thenNat` \ v2 ->
3452 FMOV DF src f0 `snocOL`
3453 ST F f0 (spRel 16) `snocOL`
3454 LD W (spRel 16) v1 `snocOL`
3455 ST F (fPair f0) (spRel 16) `snocOL`
3461 getNewRegNCG WordRep `thenNat` \ v1 ->
3464 ST F src (spRel 16) `snocOL`
3470 getNewRegNCG WordRep `thenNat` \ v1 ->
3472 code `snocOL` OR False g0 (RIReg src) v1
3476 #endif {- sparc_TARGET_ARCH -}
3478 #if powerpc_TARGET_ARCH
3480 The PowerPC calling convention (at least for Darwin/Mac OS X)
3481 is described in Apple's document
3482 "Inside Mac OS X - Mach-O Runtime Architecture".
3483 Parameters may be passed in general-purpose registers, in
3484 floating point registers, or on the stack. Stack space is
3485 always reserved for parameters, even if they are passed in registers.
3486 The called routine may choose to save parameters from registers
3487 to the corresponding space on the stack.
3488 The parameter area should be part of the caller's stack frame,
3489 allocated in the caller's prologue code (large enough to hold
3490 the parameter lists for all called routines). The NCG already
3491 uses the space that we should use as a parameter area for register
3492 spilling, so we allocate a new stack frame just before ccalling.
3493 That way we don't need to decide beforehand how much space to
3494 reserve for parameters.
3497 genCCall fn cconv kind args
3498 = mapNat prepArg args `thenNat` \ preppedArgs ->
3500 (argReps,argCodes,vregs) = unzip3 preppedArgs
3502 -- size of linkage area + size of arguments, in bytes
3503 stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3504 roundTo16 x | x `mod` 16 == 0 = x
3505 | otherwise = x + 16 - (x `mod` 16)
3507 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3508 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3510 (moveFinalCode,usedRegs) = move_final
3512 allArgRegs allFPArgRegs
3516 passArguments = concatOL argCodes
3517 `appOL` move_sp_down
3518 `appOL` moveFinalCode
3522 addImportNat lbl `thenNat` \ _ ->
3523 returnNat (passArguments
3524 `snocOL` BL (ImmLit $ ftext
3527 `appendFS` FSLIT("$stub")))
3531 getRegister dyn `thenNat` \ dynReg ->
3532 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3533 returnNat (registerCode dynReg tmp
3534 `appOL` passArguments
3535 `snocOL` MTCTR (registerName dynReg tmp)
3536 `snocOL` BCTRL usedRegs
3540 | is64BitRep (repOfStixExpr arg)
3541 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3542 let r_lo = VirtualRegI vr_lo
3543 r_hi = getHiVRegFromLo r_lo
3544 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3546 = getRegister arg `thenNat` \ register ->
3547 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3548 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3549 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3550 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3551 | not (is64BitRep rep) =
3554 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3557 fpr : fprs -> MR fpr vr
3558 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3559 ((take 1 fprs) ++ accumUsed)
3561 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3564 fpr : fprs -> MR fpr vr
3565 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3566 ((take 1 fprs) ++ accumUsed)
3567 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3569 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3572 gpr : gprs -> MR gpr vr
3573 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3574 ((take 1 gprs) ++ accumUsed)
3576 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3579 storeWord vr (gpr:_) offset = MR gpr vr
3580 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3582 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3584 `snocOL` storeWord vr_hi gprs stackOffset
3585 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3586 ((take 2 gprs) ++ accumUsed)
3587 #endif {- powerpc_TARGET_ARCH -}
3589 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3592 %************************************************************************
3594 \subsection{Support bits}
3596 %************************************************************************
3598 %************************************************************************
3600 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3602 %************************************************************************
3604 Turn those condition codes into integers now (when they appear on
3605 the right hand side of an assignment).
3607 (If applicable) Do not fill the delay slots here; you will confuse the
3611 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3613 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3615 #if alpha_TARGET_ARCH
3616 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3617 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3618 #endif {- alpha_TARGET_ARCH -}
3620 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3622 #if i386_TARGET_ARCH
3625 = condIntCode cond x y `thenNat` \ condition ->
3626 getNewRegNCG IntRep `thenNat` \ tmp ->
3628 code = condCode condition
3629 cond = condName condition
3630 code__2 dst = code `appOL` toOL [
3631 SETCC cond (OpReg tmp),
3632 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3633 MOV L (OpReg tmp) (OpReg dst)]
3635 returnNat (Any IntRep code__2)
3638 = getNatLabelNCG `thenNat` \ lbl1 ->
3639 getNatLabelNCG `thenNat` \ lbl2 ->
3640 condFltCode cond x y `thenNat` \ condition ->
3642 code = condCode condition
3643 cond = condName condition
3644 code__2 dst = code `appOL` toOL [
3646 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3649 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3652 returnNat (Any IntRep code__2)
3654 #endif {- i386_TARGET_ARCH -}
3656 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3658 #if sparc_TARGET_ARCH
3660 condIntReg EQQ x (StInt 0)
3661 = getRegister x `thenNat` \ register ->
3662 getNewRegNCG IntRep `thenNat` \ tmp ->
3664 code = registerCode register tmp
3665 src = registerName register tmp
3666 code__2 dst = code `appOL` toOL [
3667 SUB False True g0 (RIReg src) g0,
3668 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3670 returnNat (Any IntRep code__2)
3673 = getRegister x `thenNat` \ register1 ->
3674 getRegister y `thenNat` \ register2 ->
3675 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3676 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3678 code1 = registerCode register1 tmp1
3679 src1 = registerName register1 tmp1
3680 code2 = registerCode register2 tmp2
3681 src2 = registerName register2 tmp2
3682 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3683 XOR False src1 (RIReg src2) dst,
3684 SUB False True g0 (RIReg dst) g0,
3685 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3687 returnNat (Any IntRep code__2)
3689 condIntReg NE x (StInt 0)
3690 = getRegister x `thenNat` \ register ->
3691 getNewRegNCG IntRep `thenNat` \ tmp ->
3693 code = registerCode register tmp
3694 src = registerName register tmp
3695 code__2 dst = code `appOL` toOL [
3696 SUB False True g0 (RIReg src) g0,
3697 ADD True False g0 (RIImm (ImmInt 0)) dst]
3699 returnNat (Any IntRep code__2)
3702 = getRegister x `thenNat` \ register1 ->
3703 getRegister y `thenNat` \ register2 ->
3704 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3705 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3707 code1 = registerCode register1 tmp1
3708 src1 = registerName register1 tmp1
3709 code2 = registerCode register2 tmp2
3710 src2 = registerName register2 tmp2
3711 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3712 XOR False src1 (RIReg src2) dst,
3713 SUB False True g0 (RIReg dst) g0,
3714 ADD True False g0 (RIImm (ImmInt 0)) dst]
3716 returnNat (Any IntRep code__2)
3719 = getNatLabelNCG `thenNat` \ lbl1 ->
3720 getNatLabelNCG `thenNat` \ lbl2 ->
3721 condIntCode cond x y `thenNat` \ condition ->
3723 code = condCode condition
3724 cond = condName condition
3725 code__2 dst = code `appOL` toOL [
3726 BI cond False (ImmCLbl lbl1), NOP,
3727 OR False g0 (RIImm (ImmInt 0)) dst,
3728 BI ALWAYS False (ImmCLbl lbl2), NOP,
3730 OR False g0 (RIImm (ImmInt 1)) dst,
3733 returnNat (Any IntRep code__2)
3736 = getNatLabelNCG `thenNat` \ lbl1 ->
3737 getNatLabelNCG `thenNat` \ lbl2 ->
3738 condFltCode cond x y `thenNat` \ condition ->
3740 code = condCode condition
3741 cond = condName condition
3742 code__2 dst = code `appOL` toOL [
3744 BF cond False (ImmCLbl lbl1), NOP,
3745 OR False g0 (RIImm (ImmInt 0)) dst,
3746 BI ALWAYS False (ImmCLbl lbl2), NOP,
3748 OR False g0 (RIImm (ImmInt 1)) dst,
3751 returnNat (Any IntRep code__2)
3753 #endif {- sparc_TARGET_ARCH -}
3755 #if powerpc_TARGET_ARCH
3757 = getNatLabelNCG `thenNat` \ lbl ->
3758 condIntCode cond x y `thenNat` \ condition ->
3760 code = condCode condition
3761 cond = condName condition
3762 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3767 returnNat (Any IntRep code__2)
3770 = getNatLabelNCG `thenNat` \ lbl ->
3771 condFltCode cond x y `thenNat` \ condition ->
3773 code = condCode condition
3774 cond = condName condition
3775 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3780 returnNat (Any IntRep code__2)
3781 #endif {- powerpc_TARGET_ARCH -}
3783 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3786 %************************************************************************
3788 \subsubsection{@trivial*Code@: deal with trivial instructions}
3790 %************************************************************************
3792 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3793 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3794 for constants on the right hand side, because that's where the generic
3795 optimizer will have put them.
3797 Similarly, for unary instructions, we don't have to worry about
3798 matching an StInt as the argument, because genericOpt will already
3799 have handled the constant-folding.
3803 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3804 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3805 -> Maybe (Operand -> Operand -> Instr)
3806 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3807 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3809 -> StixExpr -> StixExpr -- the two arguments
3814 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3815 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3816 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3817 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3819 -> StixExpr -> StixExpr -- the two arguments
3823 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3824 ,IF_ARCH_i386 ((Operand -> Instr)
3825 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3826 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3828 -> StixExpr -- the one argument
3833 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3834 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3835 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3836 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3838 -> StixExpr -- the one argument
3841 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3843 #if alpha_TARGET_ARCH
3845 trivialCode instr x (StInt y)
3847 = getRegister x `thenNat` \ register ->
3848 getNewRegNCG IntRep `thenNat` \ tmp ->
3850 code = registerCode register tmp
3851 src1 = registerName register tmp
3852 src2 = ImmInt (fromInteger y)
3853 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3855 returnNat (Any IntRep code__2)
3857 trivialCode instr x y
3858 = getRegister x `thenNat` \ register1 ->
3859 getRegister y `thenNat` \ register2 ->
3860 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3861 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3863 code1 = registerCode register1 tmp1 []
3864 src1 = registerName register1 tmp1
3865 code2 = registerCode register2 tmp2 []
3866 src2 = registerName register2 tmp2
3867 code__2 dst = asmSeqThen [code1, code2] .
3868 mkSeqInstr (instr src1 (RIReg src2) dst)
3870 returnNat (Any IntRep code__2)
3873 trivialUCode instr x
3874 = getRegister x `thenNat` \ register ->
3875 getNewRegNCG IntRep `thenNat` \ tmp ->
3877 code = registerCode register tmp
3878 src = registerName register tmp
3879 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3881 returnNat (Any IntRep code__2)
3884 trivialFCode _ instr x y
3885 = getRegister x `thenNat` \ register1 ->
3886 getRegister y `thenNat` \ register2 ->
3887 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3888 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3890 code1 = registerCode register1 tmp1
3891 src1 = registerName register1 tmp1
3893 code2 = registerCode register2 tmp2
3894 src2 = registerName register2 tmp2
3896 code__2 dst = asmSeqThen [code1 [], code2 []] .
3897 mkSeqInstr (instr src1 src2 dst)
3899 returnNat (Any DoubleRep code__2)
3901 trivialUFCode _ instr x
3902 = getRegister x `thenNat` \ register ->
3903 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3905 code = registerCode register tmp
3906 src = registerName register tmp
3907 code__2 dst = code . mkSeqInstr (instr src dst)
3909 returnNat (Any DoubleRep code__2)
3911 #endif {- alpha_TARGET_ARCH -}
3913 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3915 #if i386_TARGET_ARCH
3917 The Rules of the Game are:
3919 * You cannot assume anything about the destination register dst;
3920 it may be anything, including a fixed reg.
3922 * You may compute an operand into a fixed reg, but you may not
3923 subsequently change the contents of that fixed reg. If you
3924 want to do so, first copy the value either to a temporary
3925 or into dst. You are free to modify dst even if it happens
3926 to be a fixed reg -- that's not your problem.
3928 * You cannot assume that a fixed reg will stay live over an
3929 arbitrary computation. The same applies to the dst reg.
3931 * Temporary regs obtained from getNewRegNCG are distinct from
3932 each other and from all other regs, and stay live over
3933 arbitrary computations.
3937 trivialCode instr maybe_revinstr a b
3940 = getRegister a `thenNat` \ rega ->
3943 then registerCode rega dst `bind` \ code_a ->
3945 instr (OpImm imm_b) (OpReg dst)
3946 else registerCodeF rega `bind` \ code_a ->
3947 registerNameF rega `bind` \ r_a ->
3949 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3950 instr (OpImm imm_b) (OpReg dst)
3952 returnNat (Any IntRep mkcode)
3955 = getRegister b `thenNat` \ regb ->
3956 getNewRegNCG IntRep `thenNat` \ tmp ->
3957 let revinstr_avail = maybeToBool maybe_revinstr
3958 revinstr = case maybe_revinstr of Just ri -> ri
3962 then registerCode regb dst `bind` \ code_b ->
3964 revinstr (OpImm imm_a) (OpReg dst)
3965 else registerCodeF regb `bind` \ code_b ->
3966 registerNameF regb `bind` \ r_b ->
3968 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3969 revinstr (OpImm imm_a) (OpReg dst)
3973 then registerCode regb tmp `bind` \ code_b ->
3975 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3976 instr (OpReg tmp) (OpReg dst)
3977 else registerCodeF regb `bind` \ code_b ->
3978 registerNameF regb `bind` \ r_b ->
3980 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3981 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3982 instr (OpReg tmp) (OpReg dst)
3984 returnNat (Any IntRep mkcode)
3987 = getRegister a `thenNat` \ rega ->
3988 getRegister b `thenNat` \ regb ->
3989 getNewRegNCG IntRep `thenNat` \ tmp ->
3991 = case (isAny rega, isAny regb) of
3993 -> registerCode regb tmp `bind` \ code_b ->
3994 registerCode rega dst `bind` \ code_a ->
3997 instr (OpReg tmp) (OpReg dst)
3999 -> registerCode rega tmp `bind` \ code_a ->
4000 registerCodeF regb `bind` \ code_b ->
4001 registerNameF regb `bind` \ r_b ->
4004 instr (OpReg r_b) (OpReg tmp) `snocOL`
4005 MOV L (OpReg tmp) (OpReg dst)
4007 -> registerCode regb tmp `bind` \ code_b ->
4008 registerCodeF rega `bind` \ code_a ->
4009 registerNameF rega `bind` \ r_a ->
4012 MOV L (OpReg r_a) (OpReg dst) `snocOL`
4013 instr (OpReg tmp) (OpReg dst)
4015 -> registerCodeF rega `bind` \ code_a ->
4016 registerNameF rega `bind` \ r_a ->
4017 registerCodeF regb `bind` \ code_b ->
4018 registerNameF regb `bind` \ r_b ->
4020 MOV L (OpReg r_a) (OpReg tmp) `appOL`
4022 instr (OpReg r_b) (OpReg tmp) `snocOL`
4023 MOV L (OpReg tmp) (OpReg dst)
4025 returnNat (Any IntRep mkcode)
4028 maybe_imm_a = maybeImm a
4029 is_imm_a = maybeToBool maybe_imm_a
4030 imm_a = case maybe_imm_a of Just imm -> imm
4032 maybe_imm_b = maybeImm b
4033 is_imm_b = maybeToBool maybe_imm_b
4034 imm_b = case maybe_imm_b of Just imm -> imm
4038 trivialUCode instr x
4039 = getRegister x `thenNat` \ register ->
4041 code__2 dst = let code = registerCode register dst
4042 src = registerName register dst
4044 if isFixed register && dst /= src
4045 then toOL [MOV L (OpReg src) (OpReg dst),
4047 else unitOL (instr (OpReg src))
4049 returnNat (Any IntRep code__2)
4052 trivialFCode pk instr x y
4053 = getRegister x `thenNat` \ register1 ->
4054 getRegister y `thenNat` \ register2 ->
4055 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4056 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4058 code1 = registerCode register1 tmp1
4059 src1 = registerName register1 tmp1
4061 code2 = registerCode register2 tmp2
4062 src2 = registerName register2 tmp2
4065 -- treat the common case specially: both operands in
4067 | isAny register1 && isAny register2
4070 instr (primRepToSize pk) src1 src2 dst
4072 -- be paranoid (and inefficient)
4074 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4076 instr (primRepToSize pk) tmp1 src2 dst
4078 returnNat (Any pk code__2)
4082 trivialUFCode pk instr x
4083 = getRegister x `thenNat` \ register ->
4084 getNewRegNCG pk `thenNat` \ tmp ->
4086 code = registerCode register tmp
4087 src = registerName register tmp
4088 code__2 dst = code `snocOL` instr src dst
4090 returnNat (Any pk code__2)
4092 #endif {- i386_TARGET_ARCH -}
4094 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4096 #if sparc_TARGET_ARCH
4098 trivialCode instr x (StInt y)
4100 = getRegister x `thenNat` \ register ->
4101 getNewRegNCG IntRep `thenNat` \ tmp ->
4103 code = registerCode register tmp
4104 src1 = registerName register tmp
4105 src2 = ImmInt (fromInteger y)
4106 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4108 returnNat (Any IntRep code__2)
4110 trivialCode instr x y
4111 = getRegister x `thenNat` \ register1 ->
4112 getRegister y `thenNat` \ register2 ->
4113 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4114 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4116 code1 = registerCode register1 tmp1
4117 src1 = registerName register1 tmp1
4118 code2 = registerCode register2 tmp2
4119 src2 = registerName register2 tmp2
4120 code__2 dst = code1 `appOL` code2 `snocOL`
4121 instr src1 (RIReg src2) dst
4123 returnNat (Any IntRep code__2)
4126 trivialFCode pk instr x y
4127 = getRegister x `thenNat` \ register1 ->
4128 getRegister y `thenNat` \ register2 ->
4129 getNewRegNCG (registerRep register1)
4131 getNewRegNCG (registerRep register2)
4133 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4135 promote x = FxTOy F DF x tmp
4137 pk1 = registerRep register1
4138 code1 = registerCode register1 tmp1
4139 src1 = registerName register1 tmp1
4141 pk2 = registerRep register2
4142 code2 = registerCode register2 tmp2
4143 src2 = registerName register2 tmp2
4147 code1 `appOL` code2 `snocOL`
4148 instr (primRepToSize pk) src1 src2 dst
4149 else if pk1 == FloatRep then
4150 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4151 instr DF tmp src2 dst
4153 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4154 instr DF src1 tmp dst
4156 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4159 trivialUCode instr x
4160 = getRegister x `thenNat` \ register ->
4161 getNewRegNCG IntRep `thenNat` \ tmp ->
4163 code = registerCode register tmp
4164 src = registerName register tmp
4165 code__2 dst = code `snocOL` instr (RIReg src) dst
4167 returnNat (Any IntRep code__2)
4170 trivialUFCode pk instr x
4171 = getRegister x `thenNat` \ register ->
4172 getNewRegNCG pk `thenNat` \ tmp ->
4174 code = registerCode register tmp
4175 src = registerName register tmp
4176 code__2 dst = code `snocOL` instr src dst
4178 returnNat (Any pk code__2)
4180 #endif {- sparc_TARGET_ARCH -}
4182 #if powerpc_TARGET_ARCH
4183 trivialCode instr x (StInt y)
4185 = getRegister x `thenNat` \ register ->
4186 getNewRegNCG IntRep `thenNat` \ tmp ->
4188 code = registerCode register tmp
4189 src1 = registerName register tmp
4190 src2 = ImmInt (fromInteger y)
4191 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4193 returnNat (Any IntRep code__2)
4195 trivialCode instr x y
4196 = getRegister x `thenNat` \ register1 ->
4197 getRegister y `thenNat` \ register2 ->
4198 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4199 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4201 code1 = registerCode register1 tmp1
4202 src1 = registerName register1 tmp1
4203 code2 = registerCode register2 tmp2
4204 src2 = registerName register2 tmp2
4205 code__2 dst = code1 `appOL` code2 `snocOL`
4206 instr dst src1 (RIReg src2)
4208 returnNat (Any IntRep code__2)
4210 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4211 -> StixExpr -> StixExpr -> NatM Register
4212 trivialCode2 instr x y
4213 = getRegister x `thenNat` \ register1 ->
4214 getRegister y `thenNat` \ register2 ->
4215 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4216 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4218 code1 = registerCode register1 tmp1
4219 src1 = registerName register1 tmp1
4220 code2 = registerCode register2 tmp2
4221 src2 = registerName register2 tmp2
4222 code__2 dst = code1 `appOL` code2 `snocOL`
4225 returnNat (Any IntRep code__2)
4227 trivialFCode pk instr x y
4228 = getRegister x `thenNat` \ register1 ->
4229 getRegister y `thenNat` \ register2 ->
4230 getNewRegNCG (registerRep register1)
4232 getNewRegNCG (registerRep register2)
4234 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4236 -- promote x = FxTOy F DF x tmp
4238 pk1 = registerRep register1
4239 code1 = registerCode register1 tmp1
4240 src1 = registerName register1 tmp1
4242 pk2 = registerRep register2
4243 code2 = registerCode register2 tmp2
4244 src2 = registerName register2 tmp2
4246 dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
4249 code1 `appOL` code2 `snocOL`
4250 instr (primRepToSize dstRep) dst src1 src2
4252 returnNat (Any dstRep code__2)
4254 trivialUCode instr x
4255 = getRegister x `thenNat` \ register ->
4256 getNewRegNCG IntRep `thenNat` \ tmp ->
4258 code = registerCode register tmp
4259 src = registerName register tmp
4260 code__2 dst = code `snocOL` instr dst src
4262 returnNat (Any IntRep code__2)
4263 trivialUFCode pk instr x
4264 = getRegister x `thenNat` \ register ->
4265 getNewRegNCG (registerRep register)
4268 code = registerCode register tmp
4269 src = registerName register tmp
4270 code__2 dst = code `snocOL` instr dst src
4272 returnNat (Any pk code__2)
4274 -- There is no "remainder" instruction on the PPC, so we have to do
4276 -- The "div" parameter is the division instruction to use (DIVW or DIVWU)
4278 remainderCode :: (Reg -> Reg -> Reg -> Instr)
4279 -> StixExpr -> StixExpr -> NatM Register
4280 remainderCode div x y
4281 = getRegister x `thenNat` \ register1 ->
4282 getRegister y `thenNat` \ register2 ->
4283 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4284 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4286 code1 = registerCode register1 tmp1
4287 src1 = registerName register1 tmp1
4288 code2 = registerCode register2 tmp2
4289 src2 = registerName register2 tmp2
4290 code__2 dst = code1 `appOL` code2 `appOL` toOL [
4292 MULLW dst dst (RIReg src2),
4293 SUBF dst dst (RIReg src1)
4296 returnNat (Any IntRep code__2)
4298 #endif {- powerpc_TARGET_ARCH -}
4300 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4303 %************************************************************************
4305 \subsubsection{Coercing to/from integer/floating-point...}
4307 %************************************************************************
4309 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4310 conversions. We have to store temporaries in memory to move
4311 between the integer and the floating point register sets.
4313 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4314 pretend, on sparc at least, that double and float regs are seperate
4315 kinds, so the value has to be computed into one kind before being
4316 explicitly "converted" to live in the other kind.
4319 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4320 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4322 coerceDbl2Flt :: StixExpr -> NatM Register
4323 coerceFlt2Dbl :: StixExpr -> NatM Register
4327 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4329 #if alpha_TARGET_ARCH
4332 = getRegister x `thenNat` \ register ->
4333 getNewRegNCG IntRep `thenNat` \ reg ->
4335 code = registerCode register reg
4336 src = registerName register reg
4338 code__2 dst = code . mkSeqInstrs [
4340 LD TF dst (spRel 0),
4343 returnNat (Any DoubleRep code__2)
4347 = getRegister x `thenNat` \ register ->
4348 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4350 code = registerCode register tmp
4351 src = registerName register tmp
4353 code__2 dst = code . mkSeqInstrs [
4355 ST TF tmp (spRel 0),
4358 returnNat (Any IntRep code__2)
4360 #endif {- alpha_TARGET_ARCH -}
4362 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4364 #if i386_TARGET_ARCH
4367 = getRegister x `thenNat` \ register ->
4368 getNewRegNCG IntRep `thenNat` \ reg ->
4370 code = registerCode register reg
4371 src = registerName register reg
4372 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4373 code__2 dst = code `snocOL` opc src dst
4375 returnNat (Any pk code__2)
4378 coerceFP2Int fprep x
4379 = getRegister x `thenNat` \ register ->
4380 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4382 code = registerCode register tmp
4383 src = registerName register tmp
4384 pk = registerRep register
4386 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4387 code__2 dst = code `snocOL` opc src dst
4389 returnNat (Any IntRep code__2)
4392 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4393 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4395 #endif {- i386_TARGET_ARCH -}
4397 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4399 #if sparc_TARGET_ARCH
4402 = getRegister x `thenNat` \ register ->
4403 getNewRegNCG IntRep `thenNat` \ reg ->
4405 code = registerCode register reg
4406 src = registerName register reg
4408 code__2 dst = code `appOL` toOL [
4409 ST W src (spRel (-2)),
4410 LD W (spRel (-2)) dst,
4411 FxTOy W (primRepToSize pk) dst dst]
4413 returnNat (Any pk code__2)
4416 coerceFP2Int fprep x
4417 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4418 getRegister x `thenNat` \ register ->
4419 getNewRegNCG fprep `thenNat` \ reg ->
4420 getNewRegNCG FloatRep `thenNat` \ tmp ->
4422 code = registerCode register reg
4423 src = registerName register reg
4424 code__2 dst = code `appOL` toOL [
4425 FxTOy (primRepToSize fprep) W src tmp,
4426 ST W tmp (spRel (-2)),
4427 LD W (spRel (-2)) dst]
4429 returnNat (Any IntRep code__2)
4433 = getRegister x `thenNat` \ register ->
4434 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4435 let code = registerCode register tmp
4436 src = registerName register tmp
4438 returnNat (Any FloatRep
4439 (\dst -> code `snocOL` FxTOy DF F src dst))
4443 = getRegister x `thenNat` \ register ->
4444 getNewRegNCG FloatRep `thenNat` \ tmp ->
4445 let code = registerCode register tmp
4446 src = registerName register tmp
4448 returnNat (Any DoubleRep
4449 (\dst -> code `snocOL` FxTOy F DF src dst))
4451 #endif {- sparc_TARGET_ARCH -}
4453 #if powerpc_TARGET_ARCH
4455 = ASSERT(pk == DoubleRep)
4456 getRegister x `thenNat` \ register ->
4457 getNewRegNCG IntRep `thenNat` \ reg ->
4458 getNatLabelNCG `thenNat` \ lbl ->
4459 getNewRegNCG PtrRep `thenNat` \ itmp ->
4460 getNewRegNCG DoubleRep `thenNat` \ ftmp ->
4462 code = registerCode register reg
4463 src = registerName register reg
4464 code__2 dst = code `appOL` toOL [
4465 SEGMENT RoDataSegment,
4467 DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
4468 SEGMENT TextSegment,
4469 XORIS itmp src (ImmInt 0x8000),
4470 ST W itmp (spRel (-1)),
4471 LIS itmp (ImmInt 0x4330),
4472 ST W itmp (spRel (-2)),
4473 LD DF ftmp (spRel (-2)),
4474 LIS itmp (HA (ImmCLbl lbl)),
4475 LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
4476 FSUB DF dst ftmp dst
4479 returnNat (Any DoubleRep code__2)
4481 coerceFP2Int fprep x
4482 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4483 getRegister x `thenNat` \ register ->
4484 getNewRegNCG fprep `thenNat` \ reg ->
4485 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4487 code = registerCode register reg
4488 src = registerName register reg
4489 code__2 dst = code `appOL` toOL [
4490 -- convert to int in FP reg
4492 -- store value (64bit) from FP to stack
4493 ST DF tmp (spRel (-2)),
4494 -- read low word of value (high word is undefined)
4495 LD W dst (spRel (-1))]
4497 returnNat (Any IntRep code__2)
4498 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4499 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4500 #endif {- powerpc_TARGET_ARCH -}
4502 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -