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,
48 import Outputable ( panic, pprPanic, showSDoc )
49 import qualified Outputable
50 import CmdLineOpts ( opt_Static )
51 import Stix ( pprStixStmt )
54 import Outputable ( assertPanic )
56 import TRACE ( trace )
61 @InstrBlock@s are the insn sequences generated by the insn selectors.
62 They are really trees of insns to facilitate fast appending, where a
63 left-to-right traversal (pre-order?) yields the insns in the correct
67 type InstrBlock = OrdList Instr
71 isLeft (Left _) = True
72 isLeft (Right _) = False
77 Code extractor for an entire stix tree---stix statement level.
80 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
82 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
83 returnNat (concatOL instrss)
86 stmtToInstrs :: StixStmt -> NatM InstrBlock
87 stmtToInstrs stmt = case stmt of
88 StComment s -> returnNat (unitOL (COMMENT s))
89 StSegment seg -> returnNat (unitOL (SEGMENT seg))
91 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
93 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
96 StLabel lab -> returnNat (unitOL (LABEL lab))
98 StJump dsts arg -> genJump dsts (derefDLL arg)
99 StCondJump lab arg -> genCondJump lab (derefDLL arg)
101 -- A call returning void, ie one done for its side-effects. Note
102 -- that this is the only StVoidable we handle.
103 StVoidable (StCall fn cconv VoidRep args)
104 -> genCCall fn cconv VoidRep (map derefDLL args)
106 StAssignMem pk addr src
107 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
108 | ncg_target_is_32bit
109 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
110 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
111 StAssignReg pk reg src
112 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
113 | ncg_target_is_32bit
114 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
115 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
118 -- When falling through on the Alpha, we still have to load pv
119 -- with the address of the next routine, so that it can load gp.
120 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
124 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
125 returnNat (DATA (primRepToSize kind) imms
126 `consOL` concatOL codes)
128 getData :: StixExpr -> NatM (InstrBlock, Imm)
129 getData (StInt i) = returnNat (nilOL, ImmInteger i)
130 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
131 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
132 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
133 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
134 -- the linker can handle simple arithmetic...
135 getData (StIndex rep (StCLbl lbl) (StInt off)) =
137 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
139 -- Top-level lifted-out string. The segment will already have been set
140 -- (see Stix.liftStrings).
142 -> returnNat (unitOL (ASCII True (unpackFS str)))
145 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
148 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
149 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
150 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
152 derefDLL :: StixExpr -> StixExpr
154 | opt_Static -- short out the entire deal if not doing DLLs
161 StCLbl lbl -> if labelDynamic lbl
162 then StInd PtrRep (StCLbl lbl)
164 -- all the rest are boring
165 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
166 StMachOp mop args -> StMachOp mop (map qq args)
167 StInd pk addr -> StInd pk (qq addr)
168 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
169 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
175 _ -> pprPanic "derefDLL: unhandled case"
179 %************************************************************************
181 \subsection{General things for putting together code sequences}
183 %************************************************************************
186 mangleIndexTree :: StixExpr -> StixExpr
188 mangleIndexTree (StIndex pk base (StInt i))
189 = StMachOp MO_Nat_Add [base, off]
191 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
193 mangleIndexTree (StIndex pk base off)
194 = StMachOp MO_Nat_Add [
197 in if s == 0 then off
198 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
201 shift :: PrimRep -> Int
202 shift rep = case getPrimRepSizeInBytes rep of
207 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
208 (Outputable.int other)
212 maybeImm :: StixExpr -> Maybe Imm
216 maybeImm (StIndex rep (StCLbl l) (StInt off))
217 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
219 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
220 = Just (ImmInt (fromInteger i))
222 = Just (ImmInteger i)
227 %************************************************************************
229 \subsection{The @Register64@ type}
231 %************************************************************************
233 Simple support for generating 64-bit code (ie, 64 bit values and 64
234 bit assignments) on 32-bit platforms. Unlike the main code generator
235 we merely shoot for generating working code as simply as possible, and
236 pay little attention to code quality. Specifically, there is no
237 attempt to deal cleverly with the fixed-vs-floating register
238 distinction; all values are generated into (pairs of) floating
239 registers, even if this would mean some redundant reg-reg moves as a
240 result. Only one of the VRegUniques is returned, since it will be
241 of the VRegUniqueLo form, and the upper-half VReg can be determined
242 by applying getHiVRegFromLo to it.
246 data ChildCode64 -- a.k.a "Register64"
249 VRegUnique -- unique for the lower 32-bit temporary
250 -- which contains the result; use getHiVRegFromLo to find
251 -- the other VRegUnique.
252 -- Rules of this simplified insn selection game are
253 -- therefore that the returned VRegUnique may be modified
255 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
256 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
257 iselExpr64 :: StixExpr -> NatM ChildCode64
259 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
263 assignMem_I64Code addrTree valueTree
264 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
265 getRegister addrTree `thenNat` \ register_addr ->
266 getNewRegNCG IntRep `thenNat` \ t_addr ->
267 let rlo = VirtualRegI vrlo
268 rhi = getHiVRegFromLo rlo
269 code_addr = registerCode register_addr t_addr
270 reg_addr = registerName register_addr t_addr
271 -- Little-endian store
272 mov_lo = MOV L (OpReg rlo)
273 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
274 mov_hi = MOV L (OpReg rhi)
275 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
277 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
279 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
280 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
282 r_dst_lo = mkVReg u_dst IntRep
283 r_src_lo = VirtualRegI vr_src_lo
284 r_dst_hi = getHiVRegFromLo r_dst_lo
285 r_src_hi = getHiVRegFromLo r_src_lo
286 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
287 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
290 vcode `snocOL` mov_lo `snocOL` mov_hi
293 assignReg_I64Code lvalue valueTree
294 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
299 iselExpr64 (StInd pk addrTree)
301 = getRegister addrTree `thenNat` \ register_addr ->
302 getNewRegNCG IntRep `thenNat` \ t_addr ->
303 getNewRegNCG IntRep `thenNat` \ rlo ->
304 let rhi = getHiVRegFromLo rlo
305 code_addr = registerCode register_addr t_addr
306 reg_addr = registerName register_addr t_addr
307 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
309 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
313 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
317 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
319 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
320 let r_dst_hi = getHiVRegFromLo r_dst_lo
321 r_src_lo = mkVReg vu IntRep
322 r_src_hi = getHiVRegFromLo r_src_lo
323 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
324 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
327 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
330 iselExpr64 (StCall fn cconv kind args)
332 = genCCall fn cconv kind args `thenNat` \ call ->
333 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
334 let r_dst_hi = getHiVRegFromLo r_dst_lo
335 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
336 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
339 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
340 (getVRegUnique r_dst_lo)
344 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
346 #endif {- i386_TARGET_ARCH -}
348 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
350 #if sparc_TARGET_ARCH
352 assignMem_I64Code addrTree valueTree
353 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
354 getRegister addrTree `thenNat` \ register_addr ->
355 getNewRegNCG IntRep `thenNat` \ t_addr ->
356 let rlo = VirtualRegI vrlo
357 rhi = getHiVRegFromLo rlo
358 code_addr = registerCode register_addr t_addr
359 reg_addr = registerName register_addr t_addr
361 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
362 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
364 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
367 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
368 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
370 r_dst_lo = mkVReg u_dst IntRep
371 r_src_lo = VirtualRegI vr_src_lo
372 r_dst_hi = getHiVRegFromLo r_dst_lo
373 r_src_hi = getHiVRegFromLo r_src_lo
374 mov_lo = mkMOV r_src_lo r_dst_lo
375 mov_hi = mkMOV r_src_hi r_dst_hi
376 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
379 vcode `snocOL` mov_hi `snocOL` mov_lo
381 assignReg_I64Code lvalue valueTree
382 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
386 -- Don't delete this -- it's very handy for debugging.
388 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
389 -- = panic "iselExpr64(???)"
391 iselExpr64 (StInd pk addrTree)
393 = getRegister addrTree `thenNat` \ register_addr ->
394 getNewRegNCG IntRep `thenNat` \ t_addr ->
395 getNewRegNCG IntRep `thenNat` \ rlo ->
396 let rhi = getHiVRegFromLo rlo
397 code_addr = registerCode register_addr t_addr
398 reg_addr = registerName register_addr t_addr
399 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
400 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
403 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
407 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
409 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
410 let r_dst_hi = getHiVRegFromLo r_dst_lo
411 r_src_lo = mkVReg vu IntRep
412 r_src_hi = getHiVRegFromLo r_src_lo
413 mov_lo = mkMOV r_src_lo r_dst_lo
414 mov_hi = mkMOV r_src_hi r_dst_hi
415 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
418 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
421 iselExpr64 (StCall fn cconv kind args)
423 = genCCall fn cconv kind args `thenNat` \ call ->
424 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
425 let r_dst_hi = getHiVRegFromLo r_dst_lo
426 mov_lo = mkMOV o0 r_dst_lo
427 mov_hi = mkMOV o1 r_dst_hi
428 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
431 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
432 (getVRegUnique r_dst_lo)
436 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
438 #endif {- sparc_TARGET_ARCH -}
439 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
441 #if powerpc_TARGET_ARCH
443 assignMem_I64Code addrTree valueTree
444 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
445 getRegister addrTree `thenNat` \ register_addr ->
446 getNewRegNCG IntRep `thenNat` \ t_addr ->
447 let rlo = VirtualRegI vrlo
448 rhi = getHiVRegFromLo rlo
449 code_addr = registerCode register_addr t_addr
450 reg_addr = registerName register_addr t_addr
452 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
453 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
455 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
458 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
459 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
461 r_dst_lo = mkVReg u_dst IntRep
462 r_src_lo = VirtualRegI vr_src_lo
463 r_dst_hi = getHiVRegFromLo r_dst_lo
464 r_src_hi = getHiVRegFromLo r_src_lo
465 mov_lo = MR r_dst_lo r_src_lo
466 mov_hi = MR r_dst_hi r_src_hi
469 vcode `snocOL` mov_hi `snocOL` mov_lo
471 assignReg_I64Code lvalue valueTree
472 = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
476 -- Don't delete this -- it's very handy for debugging.
478 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
479 -- = panic "iselExpr64(???)"
481 iselExpr64 (StInd pk addrTree)
483 = getRegister addrTree `thenNat` \ register_addr ->
484 getNewRegNCG IntRep `thenNat` \ t_addr ->
485 getNewRegNCG IntRep `thenNat` \ rlo ->
486 let rhi = getHiVRegFromLo rlo
487 code_addr = registerCode register_addr t_addr
488 reg_addr = registerName register_addr t_addr
489 mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
490 mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
493 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
497 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
499 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
500 let r_dst_hi = getHiVRegFromLo r_dst_lo
501 r_src_lo = mkVReg vu IntRep
502 r_src_hi = getHiVRegFromLo r_src_lo
503 mov_lo = MR r_dst_lo r_src_lo
504 mov_hi = MR r_dst_hi r_src_hi
507 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
510 iselExpr64 (StCall fn cconv kind args)
512 = genCCall fn cconv kind args `thenNat` \ call ->
513 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
514 let r_dst_hi = getHiVRegFromLo r_dst_lo
515 mov_lo = MR r_dst_lo r3
516 mov_hi = MR r_dst_hi r4
519 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
520 (getVRegUnique r_dst_lo)
524 = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
526 #endif {- powerpc_TARGET_ARCH -}
528 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
532 %************************************************************************
534 \subsection{The @Register@ type}
536 %************************************************************************
538 @Register@s passed up the tree. If the stix code forces the register
539 to live in a pre-decided machine register, it comes out as @Fixed@;
540 otherwise, it comes out as @Any@, and the parent can decide which
541 register to put it in.
545 = Fixed PrimRep Reg InstrBlock
546 | Any PrimRep (Reg -> InstrBlock)
548 registerCode :: Register -> Reg -> InstrBlock
549 registerCode (Fixed _ _ code) reg = code
550 registerCode (Any _ code) reg = code reg
552 registerCodeF (Fixed _ _ code) = code
553 registerCodeF (Any _ _) = panic "registerCodeF"
555 registerCodeA (Any _ code) = code
556 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
558 registerName :: Register -> Reg -> Reg
559 registerName (Fixed _ reg _) _ = reg
560 registerName (Any _ _) reg = reg
562 registerNameF (Fixed _ reg _) = reg
563 registerNameF (Any _ _) = panic "registerNameF"
565 registerRep :: Register -> PrimRep
566 registerRep (Fixed pk _ _) = pk
567 registerRep (Any pk _) = pk
569 swizzleRegisterRep :: Register -> PrimRep -> Register
570 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
571 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
573 {-# INLINE registerCode #-}
574 {-# INLINE registerCodeF #-}
575 {-# INLINE registerName #-}
576 {-# INLINE registerNameF #-}
577 {-# INLINE registerRep #-}
578 {-# INLINE isFixed #-}
581 isFixed, isAny :: Register -> Bool
582 isFixed (Fixed _ _ _) = True
583 isFixed (Any _ _) = False
585 isAny = not . isFixed
588 Generate code to get a subtree into a @Register@:
591 getRegisterReg :: StixReg -> NatM Register
592 getRegister :: StixExpr -> NatM Register
595 getRegisterReg (StixMagicId mid)
596 = case get_MagicId_reg_or_addr mid of
598 -> let pk = magicIdPrimRep mid
599 in returnNat (Fixed pk (RealReg rrno) nilOL)
601 -- By this stage, the only MagicIds remaining should be the
602 -- ones which map to a real machine register on this platform. Hence ...
603 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
605 getRegisterReg (StixTemp (StixVReg u pk))
606 = returnNat (Fixed pk (mkVReg u pk) nilOL)
610 -- Don't delete this -- it's very handy for debugging.
612 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
613 -- = panic "getRegister(???)"
615 getRegister (StReg reg)
618 getRegister tree@(StIndex _ _ _)
619 = getRegister (mangleIndexTree tree)
621 getRegister (StCall fn cconv kind args)
622 | not (ncg_target_is_32bit && is64BitRep kind)
623 = genCCall fn cconv kind args `thenNat` \ call ->
624 returnNat (Fixed kind reg call)
626 reg = if isFloatingRep kind
627 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
628 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
630 getRegister (StString s)
631 = getNatLabelNCG `thenNat` \ lbl ->
633 imm_lbl = ImmCLbl lbl
636 SEGMENT RoDataSegment,
638 ASCII True (unpackFS s),
640 #if alpha_TARGET_ARCH
641 LDA dst (AddrImm imm_lbl)
644 MOV L (OpImm imm_lbl) (OpReg dst)
646 #if sparc_TARGET_ARCH
647 SETHI (HI imm_lbl) dst,
648 OR False dst (RIImm (LO imm_lbl)) dst
650 #if powerpc_TARGET_ARCH
651 LIS dst (HI imm_lbl),
652 OR dst dst (RIImm (LO imm_lbl))
656 returnNat (Any PtrRep code)
658 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
659 -- end of machine-"independent" bit; here we go on the rest...
661 #if alpha_TARGET_ARCH
663 getRegister (StDouble d)
664 = getNatLabelNCG `thenNat` \ lbl ->
665 getNewRegNCG PtrRep `thenNat` \ tmp ->
666 let code dst = mkSeqInstrs [
669 DATA TF [ImmLab (rational d)],
671 LDA tmp (AddrImm (ImmCLbl lbl)),
672 LD TF dst (AddrReg tmp)]
674 returnNat (Any DoubleRep code)
676 getRegister (StPrim primop [x]) -- unary PrimOps
678 IntNegOp -> trivialUCode (NEG Q False) x
680 NotOp -> trivialUCode NOT x
682 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
683 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
685 OrdOp -> coerceIntCode IntRep x
688 Float2IntOp -> coerceFP2Int x
689 Int2FloatOp -> coerceInt2FP pr x
690 Double2IntOp -> coerceFP2Int x
691 Int2DoubleOp -> coerceInt2FP pr x
693 Double2FloatOp -> coerceFltCode x
694 Float2DoubleOp -> coerceFltCode x
696 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
698 fn = case other_op of
699 FloatExpOp -> FSLIT("exp")
700 FloatLogOp -> FSLIT("log")
701 FloatSqrtOp -> FSLIT("sqrt")
702 FloatSinOp -> FSLIT("sin")
703 FloatCosOp -> FSLIT("cos")
704 FloatTanOp -> FSLIT("tan")
705 FloatAsinOp -> FSLIT("asin")
706 FloatAcosOp -> FSLIT("acos")
707 FloatAtanOp -> FSLIT("atan")
708 FloatSinhOp -> FSLIT("sinh")
709 FloatCoshOp -> FSLIT("cosh")
710 FloatTanhOp -> FSLIT("tanh")
711 DoubleExpOp -> FSLIT("exp")
712 DoubleLogOp -> FSLIT("log")
713 DoubleSqrtOp -> FSLIT("sqrt")
714 DoubleSinOp -> FSLIT("sin")
715 DoubleCosOp -> FSLIT("cos")
716 DoubleTanOp -> FSLIT("tan")
717 DoubleAsinOp -> FSLIT("asin")
718 DoubleAcosOp -> FSLIT("acos")
719 DoubleAtanOp -> FSLIT("atan")
720 DoubleSinhOp -> FSLIT("sinh")
721 DoubleCoshOp -> FSLIT("cosh")
722 DoubleTanhOp -> FSLIT("tanh")
724 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
726 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
728 CharGtOp -> trivialCode (CMP LTT) y x
729 CharGeOp -> trivialCode (CMP LE) y x
730 CharEqOp -> trivialCode (CMP EQQ) x y
731 CharNeOp -> int_NE_code x y
732 CharLtOp -> trivialCode (CMP LTT) x y
733 CharLeOp -> trivialCode (CMP LE) x y
735 IntGtOp -> trivialCode (CMP LTT) y x
736 IntGeOp -> trivialCode (CMP LE) y x
737 IntEqOp -> trivialCode (CMP EQQ) x y
738 IntNeOp -> int_NE_code x y
739 IntLtOp -> trivialCode (CMP LTT) x y
740 IntLeOp -> trivialCode (CMP LE) x y
742 WordGtOp -> trivialCode (CMP ULT) y x
743 WordGeOp -> trivialCode (CMP ULE) x y
744 WordEqOp -> trivialCode (CMP EQQ) x y
745 WordNeOp -> int_NE_code x y
746 WordLtOp -> trivialCode (CMP ULT) x y
747 WordLeOp -> trivialCode (CMP ULE) x y
749 AddrGtOp -> trivialCode (CMP ULT) y x
750 AddrGeOp -> trivialCode (CMP ULE) y x
751 AddrEqOp -> trivialCode (CMP EQQ) x y
752 AddrNeOp -> int_NE_code x y
753 AddrLtOp -> trivialCode (CMP ULT) x y
754 AddrLeOp -> trivialCode (CMP ULE) x y
756 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
757 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
758 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
759 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
760 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
761 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
763 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
764 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
765 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
766 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
767 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
768 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
770 IntAddOp -> trivialCode (ADD Q False) x y
771 IntSubOp -> trivialCode (SUB Q False) x y
772 IntMulOp -> trivialCode (MUL Q False) x y
773 IntQuotOp -> trivialCode (DIV Q False) x y
774 IntRemOp -> trivialCode (REM Q False) x y
776 WordAddOp -> trivialCode (ADD Q False) x y
777 WordSubOp -> trivialCode (SUB Q False) x y
778 WordMulOp -> trivialCode (MUL Q False) x y
779 WordQuotOp -> trivialCode (DIV Q True) x y
780 WordRemOp -> trivialCode (REM Q True) x y
782 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
783 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
784 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
785 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
787 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
788 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
789 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
790 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
792 AddrAddOp -> trivialCode (ADD Q False) x y
793 AddrSubOp -> trivialCode (SUB Q False) x y
794 AddrRemOp -> trivialCode (REM Q True) x y
796 AndOp -> trivialCode AND x y
797 OrOp -> trivialCode OR x y
798 XorOp -> trivialCode XOR x y
799 SllOp -> trivialCode SLL x y
800 SrlOp -> trivialCode SRL x y
802 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
803 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
804 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
806 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
807 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
809 {- ------------------------------------------------------------
810 Some bizarre special code for getting condition codes into
811 registers. Integer non-equality is a test for equality
812 followed by an XOR with 1. (Integer comparisons always set
813 the result register to 0 or 1.) Floating point comparisons of
814 any kind leave the result in a floating point register, so we
815 need to wrangle an integer register out of things.
817 int_NE_code :: StixTree -> StixTree -> NatM Register
820 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
821 getNewRegNCG IntRep `thenNat` \ tmp ->
823 code = registerCode register tmp
824 src = registerName register tmp
825 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
827 returnNat (Any IntRep code__2)
829 {- ------------------------------------------------------------
830 Comments for int_NE_code also apply to cmpF_code
833 :: (Reg -> Reg -> Reg -> Instr)
835 -> StixTree -> StixTree
838 cmpF_code instr cond x y
839 = trivialFCode pr instr x y `thenNat` \ register ->
840 getNewRegNCG DoubleRep `thenNat` \ tmp ->
841 getNatLabelNCG `thenNat` \ lbl ->
843 code = registerCode register tmp
844 result = registerName register tmp
846 code__2 dst = code . mkSeqInstrs [
847 OR zeroh (RIImm (ImmInt 1)) dst,
848 BF cond result (ImmCLbl lbl),
849 OR zeroh (RIReg zeroh) dst,
852 returnNat (Any IntRep code__2)
854 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
855 ------------------------------------------------------------
857 getRegister (StInd pk mem)
858 = getAmode mem `thenNat` \ amode ->
860 code = amodeCode amode
861 src = amodeAddr amode
862 size = primRepToSize pk
863 code__2 dst = code . mkSeqInstr (LD size dst src)
865 returnNat (Any pk code__2)
867 getRegister (StInt i)
870 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
872 returnNat (Any IntRep code)
875 code dst = mkSeqInstr (LDI Q dst src)
877 returnNat (Any IntRep code)
879 src = ImmInt (fromInteger i)
884 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
886 returnNat (Any PtrRep code)
889 imm__2 = case imm of Just x -> x
891 #endif {- alpha_TARGET_ARCH -}
893 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
897 getRegister (StFloat f)
898 = getNatLabelNCG `thenNat` \ lbl ->
899 let code dst = toOL [
904 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
907 returnNat (Any FloatRep code)
910 getRegister (StDouble d)
913 = let code dst = unitOL (GLDZ dst)
914 in returnNat (Any DoubleRep code)
917 = let code dst = unitOL (GLD1 dst)
918 in returnNat (Any DoubleRep code)
921 = getNatLabelNCG `thenNat` \ lbl ->
922 let code dst = toOL [
925 DATA DF [ImmDouble d],
927 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
930 returnNat (Any DoubleRep code)
933 getRegister (StMachOp mop [x]) -- unary MachOps
935 MO_NatS_Neg -> trivialUCode (NEGI L) x
936 MO_Nat_Not -> trivialUCode (NOT L) x
937 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
939 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
940 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
942 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
943 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
945 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
946 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
948 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
949 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
951 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
952 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
954 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
955 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
956 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
957 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
959 -- Conversions which are a nop on x86
960 MO_32U_to_NatS -> conversionNop IntRep x
961 MO_32S_to_NatS -> conversionNop IntRep x
962 MO_NatS_to_32U -> conversionNop WordRep x
963 MO_32U_to_NatU -> conversionNop WordRep x
965 MO_NatU_to_NatS -> conversionNop IntRep x
966 MO_NatS_to_NatU -> conversionNop WordRep x
967 MO_NatP_to_NatU -> conversionNop WordRep x
968 MO_NatU_to_NatP -> conversionNop PtrRep x
969 MO_NatS_to_NatP -> conversionNop PtrRep x
970 MO_NatP_to_NatS -> conversionNop IntRep x
972 MO_Dbl_to_Flt -> conversionNop FloatRep x
973 MO_Flt_to_Dbl -> conversionNop DoubleRep x
975 -- sign-extending widenings
976 MO_8U_to_NatU -> integerExtend False 24 x
977 MO_8S_to_NatS -> integerExtend True 24 x
978 MO_16U_to_NatU -> integerExtend False 16 x
979 MO_16S_to_NatS -> integerExtend True 16 x
980 MO_8U_to_32U -> integerExtend False 24 x
984 (if is_float_op then demote else id)
985 (StCall (Left fn) CCallConv DoubleRep
986 [(if is_float_op then promote else id) x])
989 integerExtend signed nBits x
991 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
992 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
995 conversionNop new_rep expr
996 = getRegister expr `thenNat` \ e_code ->
997 returnNat (swizzleRegisterRep e_code new_rep)
999 promote x = StMachOp MO_Flt_to_Dbl [x]
1000 demote x = StMachOp MO_Dbl_to_Flt [x]
1003 MO_Flt_Exp -> (True, FSLIT("exp"))
1004 MO_Flt_Log -> (True, FSLIT("log"))
1006 MO_Flt_Asin -> (True, FSLIT("asin"))
1007 MO_Flt_Acos -> (True, FSLIT("acos"))
1008 MO_Flt_Atan -> (True, FSLIT("atan"))
1010 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1011 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1012 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1014 MO_Dbl_Exp -> (False, FSLIT("exp"))
1015 MO_Dbl_Log -> (False, FSLIT("log"))
1017 MO_Dbl_Asin -> (False, FSLIT("asin"))
1018 MO_Dbl_Acos -> (False, FSLIT("acos"))
1019 MO_Dbl_Atan -> (False, FSLIT("atan"))
1021 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1022 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1023 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1025 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
1029 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
1031 MO_32U_Gt -> condIntReg GTT x y
1032 MO_32U_Ge -> condIntReg GE x y
1033 MO_32U_Eq -> condIntReg EQQ x y
1034 MO_32U_Ne -> condIntReg NE x y
1035 MO_32U_Lt -> condIntReg LTT x y
1036 MO_32U_Le -> condIntReg LE x y
1038 MO_Nat_Eq -> condIntReg EQQ x y
1039 MO_Nat_Ne -> condIntReg NE x y
1041 MO_NatS_Gt -> condIntReg GTT x y
1042 MO_NatS_Ge -> condIntReg GE x y
1043 MO_NatS_Lt -> condIntReg LTT x y
1044 MO_NatS_Le -> condIntReg LE x y
1046 MO_NatU_Gt -> condIntReg GU x y
1047 MO_NatU_Ge -> condIntReg GEU x y
1048 MO_NatU_Lt -> condIntReg LU x y
1049 MO_NatU_Le -> condIntReg LEU x y
1051 MO_Flt_Gt -> condFltReg GTT x y
1052 MO_Flt_Ge -> condFltReg GE x y
1053 MO_Flt_Eq -> condFltReg EQQ x y
1054 MO_Flt_Ne -> condFltReg NE x y
1055 MO_Flt_Lt -> condFltReg LTT x y
1056 MO_Flt_Le -> condFltReg LE x y
1058 MO_Dbl_Gt -> condFltReg GTT x y
1059 MO_Dbl_Ge -> condFltReg GE x y
1060 MO_Dbl_Eq -> condFltReg EQQ x y
1061 MO_Dbl_Ne -> condFltReg NE x y
1062 MO_Dbl_Lt -> condFltReg LTT x y
1063 MO_Dbl_Le -> condFltReg LE x y
1065 MO_Nat_Add -> add_code L x y
1066 MO_Nat_Sub -> sub_code L x y
1067 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
1068 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
1069 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
1070 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
1071 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
1072 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
1073 MO_NatS_MulMayOflo -> imulMayOflo x y
1075 MO_Flt_Add -> trivialFCode FloatRep GADD x y
1076 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
1077 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
1078 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
1080 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
1081 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
1082 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
1083 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
1085 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
1086 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
1087 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1089 {- Shift ops on x86s have constraints on their source, it
1090 either has to be Imm, CL or 1
1091 => trivialCode's is not restrictive enough (sigh.)
1093 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
1094 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1095 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1097 MO_Flt_Pwr -> getRegister (demote
1098 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1099 [promote x, promote y])
1101 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1103 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1105 promote x = StMachOp MO_Flt_to_Dbl [x]
1106 demote x = StMachOp MO_Dbl_to_Flt [x]
1108 --------------------
1109 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1111 = getNewRegNCG IntRep `thenNat` \ t1 ->
1112 getNewRegNCG IntRep `thenNat` \ t2 ->
1113 getNewRegNCG IntRep `thenNat` \ res_lo ->
1114 getNewRegNCG IntRep `thenNat` \ res_hi ->
1115 getRegister a1 `thenNat` \ reg1 ->
1116 getRegister a2 `thenNat` \ reg2 ->
1117 let code1 = registerCode reg1 t1
1118 code2 = registerCode reg2 t2
1119 src1 = registerName reg1 t1
1120 src2 = registerName reg2 t2
1121 code dst = code1 `appOL` code2 `appOL`
1123 MOV L (OpReg src1) (OpReg res_hi),
1124 MOV L (OpReg src2) (OpReg res_lo),
1125 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1126 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1127 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1128 MOV L (OpReg res_lo) (OpReg dst)
1129 -- dst==0 if high part == sign extended low part
1132 returnNat (Any IntRep code)
1134 --------------------
1135 shift_code :: (Imm -> Operand -> Instr)
1140 {- Case1: shift length as immediate -}
1141 -- Code is the same as the first eq. for trivialCode -- sigh.
1142 shift_code instr x y{-amount-}
1144 = getRegister x `thenNat` \ regx ->
1147 then registerCodeA regx dst `bind` \ code_x ->
1149 instr imm__2 (OpReg dst)
1150 else registerCodeF regx `bind` \ code_x ->
1151 registerNameF regx `bind` \ r_x ->
1153 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1154 instr imm__2 (OpReg dst)
1156 returnNat (Any IntRep mkcode)
1159 imm__2 = case imm of Just x -> x
1161 {- Case2: shift length is complex (non-immediate) -}
1162 -- Since ECX is always used as a spill temporary, we can't
1163 -- use it here to do non-immediate shifts. No big deal --
1164 -- they are only very rare, and we can use an equivalent
1165 -- test-and-jump sequence which doesn't use ECX.
1166 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1167 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1168 shift_code instr x y{-amount-}
1169 = getRegister x `thenNat` \ register1 ->
1170 getRegister y `thenNat` \ register2 ->
1171 getNatLabelNCG `thenNat` \ lbl_test3 ->
1172 getNatLabelNCG `thenNat` \ lbl_test2 ->
1173 getNatLabelNCG `thenNat` \ lbl_test1 ->
1174 getNatLabelNCG `thenNat` \ lbl_test0 ->
1175 getNatLabelNCG `thenNat` \ lbl_after ->
1176 getNewRegNCG IntRep `thenNat` \ tmp ->
1178 = let src_val = registerName register1 dst
1179 code_val = registerCode register1 dst
1180 src_amt = registerName register2 tmp
1181 code_amt = registerCode register2 tmp
1186 MOV L (OpReg src_amt) r_tmp `appOL`
1188 MOV L (OpReg src_val) r_dst `appOL`
1190 COMMENT (mkFastString "begin shift sequence"),
1191 MOV L (OpReg src_val) r_dst,
1192 MOV L (OpReg src_amt) r_tmp,
1194 BT L (ImmInt 4) r_tmp,
1196 instr (ImmInt 16) r_dst,
1199 BT L (ImmInt 3) r_tmp,
1201 instr (ImmInt 8) r_dst,
1204 BT L (ImmInt 2) r_tmp,
1206 instr (ImmInt 4) r_dst,
1209 BT L (ImmInt 1) r_tmp,
1211 instr (ImmInt 2) r_dst,
1214 BT L (ImmInt 0) r_tmp,
1216 instr (ImmInt 1) r_dst,
1219 COMMENT (mkFastString "end shift sequence")
1222 returnNat (Any IntRep code__2)
1224 --------------------
1225 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1227 add_code sz x (StInt y)
1228 = getRegister x `thenNat` \ register ->
1229 getNewRegNCG IntRep `thenNat` \ tmp ->
1231 code = registerCode register tmp
1232 src1 = registerName register tmp
1233 src2 = ImmInt (fromInteger y)
1236 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1239 returnNat (Any IntRep code__2)
1241 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1243 --------------------
1244 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1246 sub_code sz x (StInt y)
1247 = getRegister x `thenNat` \ register ->
1248 getNewRegNCG IntRep `thenNat` \ tmp ->
1250 code = registerCode register tmp
1251 src1 = registerName register tmp
1252 src2 = ImmInt (-(fromInteger y))
1255 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1258 returnNat (Any IntRep code__2)
1260 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1262 getRegister (StInd pk mem)
1263 | not (is64BitRep pk)
1264 = getAmode mem `thenNat` \ amode ->
1266 code = amodeCode amode
1267 src = amodeAddr amode
1268 size = primRepToSize pk
1269 code__2 dst = code `snocOL`
1270 if pk == DoubleRep || pk == FloatRep
1271 then GLD size src dst
1279 (OpAddr src) (OpReg dst)
1281 returnNat (Any pk code__2)
1283 getRegister (StInt i)
1285 src = ImmInt (fromInteger i)
1288 = unitOL (XOR L (OpReg dst) (OpReg dst))
1290 = unitOL (MOV L (OpImm src) (OpReg dst))
1292 returnNat (Any IntRep code)
1296 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1298 returnNat (Any PtrRep code)
1300 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1303 imm__2 = case imm of Just x -> x
1305 #endif {- i386_TARGET_ARCH -}
1307 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1309 #if sparc_TARGET_ARCH
1311 getRegister (StFloat d)
1312 = getNatLabelNCG `thenNat` \ lbl ->
1313 getNewRegNCG PtrRep `thenNat` \ tmp ->
1314 let code dst = toOL [
1315 SEGMENT DataSegment,
1317 DATA F [ImmFloat d],
1318 SEGMENT TextSegment,
1319 SETHI (HI (ImmCLbl lbl)) tmp,
1320 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1322 returnNat (Any FloatRep code)
1324 getRegister (StDouble d)
1325 = getNatLabelNCG `thenNat` \ lbl ->
1326 getNewRegNCG PtrRep `thenNat` \ tmp ->
1327 let code dst = toOL [
1328 SEGMENT DataSegment,
1330 DATA DF [ImmDouble d],
1331 SEGMENT TextSegment,
1332 SETHI (HI (ImmCLbl lbl)) tmp,
1333 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1335 returnNat (Any DoubleRep code)
1338 getRegister (StMachOp mop [x]) -- unary PrimOps
1340 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1341 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1342 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1344 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1345 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1347 MO_Dbl_to_Flt -> coerceDbl2Flt x
1348 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1350 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1351 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1352 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1353 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1355 -- Conversions which are a nop on sparc
1356 MO_32U_to_NatS -> conversionNop IntRep x
1357 MO_32S_to_NatS -> conversionNop IntRep x
1358 MO_NatS_to_32U -> conversionNop WordRep x
1359 MO_32U_to_NatU -> conversionNop WordRep x
1361 MO_NatU_to_NatS -> conversionNop IntRep x
1362 MO_NatS_to_NatU -> conversionNop WordRep x
1363 MO_NatP_to_NatU -> conversionNop WordRep x
1364 MO_NatU_to_NatP -> conversionNop PtrRep x
1365 MO_NatS_to_NatP -> conversionNop PtrRep x
1366 MO_NatP_to_NatS -> conversionNop IntRep x
1368 -- sign-extending widenings
1369 MO_8U_to_32U -> integerExtend False 24 x
1370 MO_8U_to_NatU -> integerExtend False 24 x
1371 MO_8S_to_NatS -> integerExtend True 24 x
1372 MO_16U_to_NatU -> integerExtend False 16 x
1373 MO_16S_to_NatS -> integerExtend True 16 x
1376 let fixed_x = if is_float_op -- promote to double
1377 then StMachOp MO_Flt_to_Dbl [x]
1380 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1382 integerExtend signed nBits x
1384 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1385 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1387 conversionNop new_rep expr
1388 = getRegister expr `thenNat` \ e_code ->
1389 returnNat (swizzleRegisterRep e_code new_rep)
1393 MO_Flt_Exp -> (True, FSLIT("exp"))
1394 MO_Flt_Log -> (True, FSLIT("log"))
1395 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1397 MO_Flt_Sin -> (True, FSLIT("sin"))
1398 MO_Flt_Cos -> (True, FSLIT("cos"))
1399 MO_Flt_Tan -> (True, FSLIT("tan"))
1401 MO_Flt_Asin -> (True, FSLIT("asin"))
1402 MO_Flt_Acos -> (True, FSLIT("acos"))
1403 MO_Flt_Atan -> (True, FSLIT("atan"))
1405 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1406 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1407 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1409 MO_Dbl_Exp -> (False, FSLIT("exp"))
1410 MO_Dbl_Log -> (False, FSLIT("log"))
1411 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1413 MO_Dbl_Sin -> (False, FSLIT("sin"))
1414 MO_Dbl_Cos -> (False, FSLIT("cos"))
1415 MO_Dbl_Tan -> (False, FSLIT("tan"))
1417 MO_Dbl_Asin -> (False, FSLIT("asin"))
1418 MO_Dbl_Acos -> (False, FSLIT("acos"))
1419 MO_Dbl_Atan -> (False, FSLIT("atan"))
1421 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1422 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1423 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1425 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1429 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1431 MO_32U_Gt -> condIntReg GTT x y
1432 MO_32U_Ge -> condIntReg GE x y
1433 MO_32U_Eq -> condIntReg EQQ x y
1434 MO_32U_Ne -> condIntReg NE x y
1435 MO_32U_Lt -> condIntReg LTT x y
1436 MO_32U_Le -> condIntReg LE x y
1438 MO_Nat_Eq -> condIntReg EQQ x y
1439 MO_Nat_Ne -> condIntReg NE x y
1441 MO_NatS_Gt -> condIntReg GTT x y
1442 MO_NatS_Ge -> condIntReg GE x y
1443 MO_NatS_Lt -> condIntReg LTT x y
1444 MO_NatS_Le -> condIntReg LE x y
1446 MO_NatU_Gt -> condIntReg GU x y
1447 MO_NatU_Ge -> condIntReg GEU x y
1448 MO_NatU_Lt -> condIntReg LU x y
1449 MO_NatU_Le -> condIntReg LEU x y
1451 MO_Flt_Gt -> condFltReg GTT x y
1452 MO_Flt_Ge -> condFltReg GE x y
1453 MO_Flt_Eq -> condFltReg EQQ x y
1454 MO_Flt_Ne -> condFltReg NE x y
1455 MO_Flt_Lt -> condFltReg LTT x y
1456 MO_Flt_Le -> condFltReg LE x y
1458 MO_Dbl_Gt -> condFltReg GTT x y
1459 MO_Dbl_Ge -> condFltReg GE x y
1460 MO_Dbl_Eq -> condFltReg EQQ x y
1461 MO_Dbl_Ne -> condFltReg NE x y
1462 MO_Dbl_Lt -> condFltReg LTT x y
1463 MO_Dbl_Le -> condFltReg LE x y
1465 MO_Nat_Add -> trivialCode (ADD False False) x y
1466 MO_Nat_Sub -> trivialCode (SUB False False) x y
1468 MO_NatS_Mul -> trivialCode (SMUL False) x y
1469 MO_NatU_Mul -> trivialCode (UMUL False) x y
1470 MO_NatS_MulMayOflo -> imulMayOflo x y
1472 -- ToDo: teach about V8+ SPARC div instructions
1473 MO_NatS_Quot -> idiv FSLIT(".div") x y
1474 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1475 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1476 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1478 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1479 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1480 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1481 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1483 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1484 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1485 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1486 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1488 MO_Nat_And -> trivialCode (AND False) x y
1489 MO_Nat_Or -> trivialCode (OR False) x y
1490 MO_Nat_Xor -> trivialCode (XOR False) x y
1492 MO_Nat_Shl -> trivialCode SLL x y
1493 MO_Nat_Shr -> trivialCode SRL x y
1494 MO_Nat_Sar -> trivialCode SRA x y
1496 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1497 [promote x, promote y])
1498 where promote x = StMachOp MO_Flt_to_Dbl [x]
1499 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1502 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1504 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1506 --------------------
1507 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1509 = getNewRegNCG IntRep `thenNat` \ t1 ->
1510 getNewRegNCG IntRep `thenNat` \ t2 ->
1511 getNewRegNCG IntRep `thenNat` \ res_lo ->
1512 getNewRegNCG IntRep `thenNat` \ res_hi ->
1513 getRegister a1 `thenNat` \ reg1 ->
1514 getRegister a2 `thenNat` \ reg2 ->
1515 let code1 = registerCode reg1 t1
1516 code2 = registerCode reg2 t2
1517 src1 = registerName reg1 t1
1518 src2 = registerName reg2 t2
1519 code dst = code1 `appOL` code2 `appOL`
1521 SMUL False src1 (RIReg src2) res_lo,
1523 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1524 SUB False False res_lo (RIReg res_hi) dst
1527 returnNat (Any IntRep code)
1529 getRegister (StInd pk mem)
1530 = getAmode mem `thenNat` \ amode ->
1532 code = amodeCode amode
1533 src = amodeAddr amode
1534 size = primRepToSize pk
1535 code__2 dst = code `snocOL` LD size src dst
1537 returnNat (Any pk code__2)
1539 getRegister (StInt i)
1542 src = ImmInt (fromInteger i)
1543 code dst = unitOL (OR False g0 (RIImm src) dst)
1545 returnNat (Any IntRep code)
1551 SETHI (HI imm__2) dst,
1552 OR False dst (RIImm (LO imm__2)) dst]
1554 returnNat (Any PtrRep code)
1556 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1559 imm__2 = case imm of Just x -> x
1561 #endif {- sparc_TARGET_ARCH -}
1563 #if powerpc_TARGET_ARCH
1564 getRegister (StMachOp mop [x]) -- unary MachOps
1566 MO_NatS_Neg -> trivialUCode NEG x
1567 MO_Nat_Not -> trivialUCode NOT x
1568 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1570 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1571 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1572 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1573 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1575 -- Conversions which are a nop on PPC
1576 MO_NatS_to_32U -> conversionNop WordRep x
1577 MO_32U_to_NatS -> conversionNop IntRep x
1578 MO_32U_to_NatU -> conversionNop WordRep x
1580 MO_NatU_to_NatS -> conversionNop IntRep x
1581 MO_NatS_to_NatU -> conversionNop WordRep x
1582 MO_NatP_to_NatU -> conversionNop WordRep x
1583 MO_NatU_to_NatP -> conversionNop PtrRep x
1584 MO_NatS_to_NatP -> conversionNop PtrRep x
1585 MO_NatP_to_NatS -> conversionNop IntRep x
1587 MO_Dbl_to_Flt -> conversionNop FloatRep x
1588 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1590 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1591 MO_8U_to_NatU -> integerExtend False 24 x
1592 MO_8S_to_NatS -> integerExtend True 24 x
1593 MO_16U_to_NatU -> integerExtend False 16 x
1594 MO_16S_to_NatS -> integerExtend True 16 x
1595 MO_8U_to_32U -> integerExtend False 24 x
1597 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1600 integerExtend signed nBits x
1602 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1603 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1605 conversionNop new_rep expr
1606 = getRegister expr `thenNat` \ e_code ->
1607 returnNat (swizzleRegisterRep e_code new_rep)
1609 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1611 MO_32U_Gt -> condIntReg GTT x y
1612 MO_32U_Ge -> condIntReg GE x y
1613 MO_32U_Eq -> condIntReg EQQ x y
1614 MO_32U_Ne -> condIntReg NE x y
1615 MO_32U_Lt -> condIntReg LTT x y
1616 MO_32U_Le -> condIntReg LE x y
1618 MO_Nat_Eq -> condIntReg EQQ x y
1619 MO_Nat_Ne -> condIntReg NE x y
1621 MO_NatS_Gt -> condIntReg GTT x y
1622 MO_NatS_Ge -> condIntReg GE x y
1623 MO_NatS_Lt -> condIntReg LTT x y
1624 MO_NatS_Le -> condIntReg LE x y
1626 MO_NatU_Gt -> condIntReg GU x y
1627 MO_NatU_Ge -> condIntReg GEU x y
1628 MO_NatU_Lt -> condIntReg LU x y
1629 MO_NatU_Le -> condIntReg LEU x y
1631 MO_Flt_Gt -> condFltReg GTT x y
1632 MO_Flt_Ge -> condFltReg GE x y
1633 MO_Flt_Eq -> condFltReg EQQ x y
1634 MO_Flt_Ne -> condFltReg NE x y
1635 MO_Flt_Lt -> condFltReg LTT x y
1636 MO_Flt_Le -> condFltReg LE x y
1638 MO_Dbl_Gt -> condFltReg GTT x y
1639 MO_Dbl_Ge -> condFltReg GE x y
1640 MO_Dbl_Eq -> condFltReg EQQ x y
1641 MO_Dbl_Ne -> condFltReg NE x y
1642 MO_Dbl_Lt -> condFltReg LTT x y
1643 MO_Dbl_Le -> condFltReg LE x y
1645 MO_Nat_Add -> trivialCode ADD x y
1646 MO_Nat_Sub -> trivialCode SUBF y x
1648 MO_NatS_Mul -> trivialCode MULLW x y
1649 MO_NatU_Mul -> trivialCode MULLW x y
1651 MO_NatS_Quot -> trivialCode2 DIVW x y
1652 MO_NatU_Quot -> trivialCode2 DIVWU x y
1654 MO_Nat_And -> trivialCode AND x y
1655 MO_Nat_Or -> trivialCode OR x y
1656 MO_Nat_Xor -> trivialCode XOR x y
1658 MO_Nat_Shl -> trivialCode SLW x y
1659 MO_Nat_Shr -> trivialCode SRW x y
1660 MO_Nat_Sar -> trivialCode SRAW x y
1662 {- MO_NatS_Mul -> trivialCode (SMUL False) x y
1663 MO_NatU_Mul -> trivialCode (UMUL False) x y
1664 MO_NatS_MulMayOflo -> imulMayOflo x y
1666 -- ToDo: teach about V8+ SPARC div instructions
1667 MO_NatS_Quot -> idiv FSLIT(".div") x y
1668 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1669 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1670 MO_NatU_Rem -> idiv FSLIT(".urem") x y -}
1672 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1673 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1674 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1675 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1677 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1678 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1679 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1680 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1682 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1683 [promote x, promote y])
1684 where promote x = StMachOp MO_Flt_to_Dbl [x]
1685 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1688 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1690 getRegister (StInd pk mem)
1691 = getAmode mem `thenNat` \ amode ->
1693 code = amodeCode amode
1694 src = amodeAddr amode
1695 size = primRepToSize pk
1696 code__2 dst = code `snocOL` LD size dst src
1698 returnNat (Any pk code__2)
1700 getRegister (StInt i)
1703 src = ImmInt (fromInteger i)
1704 code dst = unitOL (LI dst src)
1706 returnNat (Any IntRep code)
1708 getRegister (StFloat d)
1709 = getNatLabelNCG `thenNat` \ lbl ->
1710 getNewRegNCG PtrRep `thenNat` \ tmp ->
1711 let code dst = toOL [
1712 SEGMENT RoDataSegment,
1714 DATA F [ImmFloat d],
1715 SEGMENT TextSegment,
1716 LIS tmp (HA (ImmCLbl lbl)),
1717 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1719 returnNat (Any FloatRep code)
1721 getRegister (StDouble d)
1722 = getNatLabelNCG `thenNat` \ lbl ->
1723 getNewRegNCG PtrRep `thenNat` \ tmp ->
1724 let code dst = toOL [
1725 SEGMENT RoDataSegment,
1727 DATA DF [ImmDouble d],
1728 SEGMENT TextSegment,
1729 LIS tmp (HA (ImmCLbl lbl)),
1730 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1732 returnNat (Any DoubleRep code)
1738 LIS dst (HI imm__2),
1739 OR dst dst (RIImm (LO imm__2))]
1741 returnNat (Any PtrRep code)
1743 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1746 imm__2 = case imm of Just x -> x
1747 #endif {- powerpc_TARGET_ARCH -}
1749 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1751 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1755 %************************************************************************
1757 \subsection{The @Amode@ type}
1759 %************************************************************************
1761 @Amode@s: Memory addressing modes passed up the tree.
1763 data Amode = Amode MachRegsAddr InstrBlock
1765 amodeAddr (Amode addr _) = addr
1766 amodeCode (Amode _ code) = code
1769 Now, given a tree (the argument to an StInd) that references memory,
1770 produce a suitable addressing mode.
1772 A Rule of the Game (tm) for Amodes: use of the addr bit must
1773 immediately follow use of the code part, since the code part puts
1774 values in registers which the addr then refers to. So you can't put
1775 anything in between, lest it overwrite some of those registers. If
1776 you need to do some other computation between the code part and use of
1777 the addr bit, first store the effective address from the amode in a
1778 temporary, then do the other computation, and then use the temporary:
1782 ... other computation ...
1786 getAmode :: StixExpr -> NatM Amode
1788 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1792 #if alpha_TARGET_ARCH
1794 getAmode (StPrim IntSubOp [x, StInt i])
1795 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1796 getRegister x `thenNat` \ register ->
1798 code = registerCode register tmp
1799 reg = registerName register tmp
1800 off = ImmInt (-(fromInteger i))
1802 returnNat (Amode (AddrRegImm reg off) code)
1804 getAmode (StPrim IntAddOp [x, StInt i])
1805 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1806 getRegister x `thenNat` \ register ->
1808 code = registerCode register tmp
1809 reg = registerName register tmp
1810 off = ImmInt (fromInteger i)
1812 returnNat (Amode (AddrRegImm reg off) code)
1816 = returnNat (Amode (AddrImm imm__2) id)
1819 imm__2 = case imm of Just x -> x
1822 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1823 getRegister other `thenNat` \ register ->
1825 code = registerCode register tmp
1826 reg = registerName register tmp
1828 returnNat (Amode (AddrReg reg) code)
1830 #endif {- alpha_TARGET_ARCH -}
1832 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1834 #if i386_TARGET_ARCH
1836 -- This is all just ridiculous, since it carefully undoes
1837 -- what mangleIndexTree has just done.
1838 getAmode (StMachOp MO_Nat_Sub [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 (AddrBaseIndex (Just reg) Nothing off) code)
1848 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1850 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1853 imm__2 = case imm of Just x -> x
1855 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1856 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1857 getRegister x `thenNat` \ register ->
1859 code = registerCode register tmp
1860 reg = registerName register tmp
1861 off = ImmInt (fromInteger i)
1863 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1865 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1866 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1867 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1868 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1869 getRegister x `thenNat` \ register1 ->
1870 getRegister y `thenNat` \ register2 ->
1872 code1 = registerCode register1 tmp1
1873 reg1 = registerName register1 tmp1
1874 code2 = registerCode register2 tmp2
1875 reg2 = registerName register2 tmp2
1876 code__2 = code1 `appOL` code2
1877 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1879 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1884 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1887 imm__2 = case imm of Just x -> x
1890 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1891 getRegister other `thenNat` \ register ->
1893 code = registerCode register tmp
1894 reg = registerName register tmp
1896 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1898 #endif {- i386_TARGET_ARCH -}
1900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1902 #if sparc_TARGET_ARCH
1904 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1906 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1907 getRegister x `thenNat` \ register ->
1909 code = registerCode register tmp
1910 reg = registerName register tmp
1911 off = ImmInt (-(fromInteger i))
1913 returnNat (Amode (AddrRegImm reg off) code)
1916 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1918 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1919 getRegister x `thenNat` \ register ->
1921 code = registerCode register tmp
1922 reg = registerName register tmp
1923 off = ImmInt (fromInteger i)
1925 returnNat (Amode (AddrRegImm reg off) code)
1927 getAmode (StMachOp MO_Nat_Add [x, y])
1928 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1929 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1930 getRegister x `thenNat` \ register1 ->
1931 getRegister y `thenNat` \ register2 ->
1933 code1 = registerCode register1 tmp1
1934 reg1 = registerName register1 tmp1
1935 code2 = registerCode register2 tmp2
1936 reg2 = registerName register2 tmp2
1937 code__2 = code1 `appOL` code2
1939 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1943 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1945 code = unitOL (SETHI (HI imm__2) tmp)
1947 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1950 imm__2 = case imm of Just x -> x
1953 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1954 getRegister other `thenNat` \ register ->
1956 code = registerCode register tmp
1957 reg = registerName register tmp
1960 returnNat (Amode (AddrRegImm reg off) code)
1962 #endif {- sparc_TARGET_ARCH -}
1964 #ifdef powerpc_TARGET_ARCH
1965 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1967 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1968 getRegister x `thenNat` \ register ->
1970 code = registerCode register tmp
1971 reg = registerName register tmp
1972 off = ImmInt (-(fromInteger i))
1974 returnNat (Amode (AddrRegImm reg off) code)
1977 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1979 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1980 getRegister x `thenNat` \ register ->
1982 code = registerCode register tmp
1983 reg = registerName register tmp
1984 off = ImmInt (fromInteger i)
1986 returnNat (Amode (AddrRegImm reg off) code)
1990 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1992 code = unitOL (LIS tmp (HA imm__2))
1994 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1997 imm__2 = case imm of Just x -> x
2000 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2001 getRegister other `thenNat` \ register ->
2003 code = registerCode register tmp
2004 reg = registerName register tmp
2007 returnNat (Amode (AddrRegImm reg off) code)
2008 #endif {- powerpc_TARGET_ARCH -}
2010 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2013 %************************************************************************
2015 \subsection{The @CondCode@ type}
2017 %************************************************************************
2019 Condition codes passed up the tree.
2021 data CondCode = CondCode Bool Cond InstrBlock
2023 condName (CondCode _ cond _) = cond
2024 condFloat (CondCode is_float _ _) = is_float
2025 condCode (CondCode _ _ code) = code
2028 Set up a condition code for a conditional branch.
2031 getCondCode :: StixExpr -> NatM CondCode
2033 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2035 #if alpha_TARGET_ARCH
2036 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2037 #endif {- alpha_TARGET_ARCH -}
2039 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2041 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2042 -- yes, they really do seem to want exactly the same!
2044 getCondCode (StMachOp mop [x, y])
2046 MO_32U_Gt -> condIntCode GTT x y
2047 MO_32U_Ge -> condIntCode GE x y
2048 MO_32U_Eq -> condIntCode EQQ x y
2049 MO_32U_Ne -> condIntCode NE x y
2050 MO_32U_Lt -> condIntCode LTT x y
2051 MO_32U_Le -> condIntCode LE x y
2053 MO_Nat_Eq -> condIntCode EQQ x y
2054 MO_Nat_Ne -> condIntCode NE x y
2056 MO_NatS_Gt -> condIntCode GTT x y
2057 MO_NatS_Ge -> condIntCode GE x y
2058 MO_NatS_Lt -> condIntCode LTT x y
2059 MO_NatS_Le -> condIntCode LE x y
2061 MO_NatU_Gt -> condIntCode GU x y
2062 MO_NatU_Ge -> condIntCode GEU x y
2063 MO_NatU_Lt -> condIntCode LU x y
2064 MO_NatU_Le -> condIntCode LEU x y
2066 MO_Flt_Gt -> condFltCode GTT x y
2067 MO_Flt_Ge -> condFltCode GE x y
2068 MO_Flt_Eq -> condFltCode EQQ x y
2069 MO_Flt_Ne -> condFltCode NE x y
2070 MO_Flt_Lt -> condFltCode LTT x y
2071 MO_Flt_Le -> condFltCode LE x y
2073 MO_Dbl_Gt -> condFltCode GTT x y
2074 MO_Dbl_Ge -> condFltCode GE x y
2075 MO_Dbl_Eq -> condFltCode EQQ x y
2076 MO_Dbl_Ne -> condFltCode NE x y
2077 MO_Dbl_Lt -> condFltCode LTT x y
2078 MO_Dbl_Le -> condFltCode LE x y
2080 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2082 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2084 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH -}
2087 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2092 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2093 passed back up the tree.
2096 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2098 #if alpha_TARGET_ARCH
2099 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2100 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2101 #endif {- alpha_TARGET_ARCH -}
2103 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2104 #if i386_TARGET_ARCH
2106 -- memory vs immediate
2107 condIntCode cond (StInd pk x) y
2108 | Just i <- maybeImm y
2109 = getAmode x `thenNat` \ amode ->
2111 code1 = amodeCode amode
2112 x__2 = amodeAddr amode
2113 sz = primRepToSize pk
2114 code__2 = code1 `snocOL`
2115 CMP sz (OpImm i) (OpAddr x__2)
2117 returnNat (CondCode False cond code__2)
2120 condIntCode cond x (StInt 0)
2121 = getRegister x `thenNat` \ register1 ->
2122 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2124 code1 = registerCode register1 tmp1
2125 src1 = registerName register1 tmp1
2126 code__2 = code1 `snocOL`
2127 TEST L (OpReg src1) (OpReg src1)
2129 returnNat (CondCode False cond code__2)
2131 -- anything vs immediate
2132 condIntCode cond x y
2133 | Just i <- maybeImm y
2134 = getRegister x `thenNat` \ register1 ->
2135 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2137 code1 = registerCode register1 tmp1
2138 src1 = registerName register1 tmp1
2139 code__2 = code1 `snocOL`
2140 CMP L (OpImm i) (OpReg src1)
2142 returnNat (CondCode False cond code__2)
2144 -- memory vs anything
2145 condIntCode cond (StInd pk x) y
2146 = getAmode x `thenNat` \ amode_x ->
2147 getRegister y `thenNat` \ reg_y ->
2148 getNewRegNCG IntRep `thenNat` \ tmp ->
2150 c_x = amodeCode amode_x
2151 am_x = amodeAddr amode_x
2152 c_y = registerCode reg_y tmp
2153 r_y = registerName reg_y tmp
2154 sz = primRepToSize pk
2156 -- optimisation: if there's no code for x, just an amode,
2157 -- use whatever reg y winds up in. Assumes that c_y doesn't
2158 -- clobber any regs in the amode am_x, which I'm not sure is
2159 -- justified. The otherwise clause makes the same assumption.
2160 code__2 | isNilOL c_x
2162 CMP sz (OpReg r_y) (OpAddr am_x)
2166 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2168 CMP sz (OpReg tmp) (OpAddr am_x)
2170 returnNat (CondCode False cond code__2)
2172 -- anything vs memory
2174 condIntCode cond y (StInd pk x)
2175 = getAmode x `thenNat` \ amode_x ->
2176 getRegister y `thenNat` \ reg_y ->
2177 getNewRegNCG IntRep `thenNat` \ tmp ->
2179 c_x = amodeCode amode_x
2180 am_x = amodeAddr amode_x
2181 c_y = registerCode reg_y tmp
2182 r_y = registerName reg_y tmp
2183 sz = primRepToSize pk
2184 -- same optimisation and nagging doubts as previous clause
2185 code__2 | isNilOL c_x
2187 CMP sz (OpAddr am_x) (OpReg r_y)
2191 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2193 CMP sz (OpAddr am_x) (OpReg tmp)
2195 returnNat (CondCode False cond code__2)
2197 -- anything vs anything
2198 condIntCode cond x y
2199 = getRegister x `thenNat` \ register1 ->
2200 getRegister y `thenNat` \ register2 ->
2201 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2202 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2204 code1 = registerCode register1 tmp1
2205 src1 = registerName register1 tmp1
2206 code2 = registerCode register2 tmp2
2207 src2 = registerName register2 tmp2
2208 code__2 = code1 `snocOL`
2209 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2211 CMP L (OpReg src2) (OpReg tmp1)
2213 returnNat (CondCode False cond code__2)
2216 condFltCode cond x y
2217 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2218 getRegister x `thenNat` \ register1 ->
2219 getRegister y `thenNat` \ register2 ->
2220 getNewRegNCG (registerRep register1)
2222 getNewRegNCG (registerRep register2)
2224 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2226 code1 = registerCode register1 tmp1
2227 src1 = registerName register1 tmp1
2229 code2 = registerCode register2 tmp2
2230 src2 = registerName register2 tmp2
2232 code__2 | isAny register1
2233 = code1 `appOL` -- result in tmp1
2239 GMOV src1 tmp1 `appOL`
2243 -- The GCMP insn does the test and sets the zero flag if comparable
2244 -- and true. Hence we always supply EQQ as the condition to test.
2245 returnNat (CondCode True EQQ code__2)
2247 #endif {- i386_TARGET_ARCH -}
2249 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2251 #if sparc_TARGET_ARCH
2253 condIntCode cond x (StInt y)
2255 = getRegister x `thenNat` \ register ->
2256 getNewRegNCG IntRep `thenNat` \ tmp ->
2258 code = registerCode register tmp
2259 src1 = registerName register tmp
2260 src2 = ImmInt (fromInteger y)
2261 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2263 returnNat (CondCode False cond code__2)
2265 condIntCode cond x y
2266 = getRegister x `thenNat` \ register1 ->
2267 getRegister y `thenNat` \ register2 ->
2268 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2269 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2271 code1 = registerCode register1 tmp1
2272 src1 = registerName register1 tmp1
2273 code2 = registerCode register2 tmp2
2274 src2 = registerName register2 tmp2
2275 code__2 = code1 `appOL` code2 `snocOL`
2276 SUB False True src1 (RIReg src2) g0
2278 returnNat (CondCode False cond code__2)
2281 condFltCode cond x y
2282 = getRegister x `thenNat` \ register1 ->
2283 getRegister y `thenNat` \ register2 ->
2284 getNewRegNCG (registerRep register1)
2286 getNewRegNCG (registerRep register2)
2288 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2290 promote x = FxTOy F DF x tmp
2292 pk1 = registerRep register1
2293 code1 = registerCode register1 tmp1
2294 src1 = registerName register1 tmp1
2296 pk2 = registerRep register2
2297 code2 = registerCode register2 tmp2
2298 src2 = registerName register2 tmp2
2302 code1 `appOL` code2 `snocOL`
2303 FCMP True (primRepToSize pk1) src1 src2
2304 else if pk1 == FloatRep then
2305 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2306 FCMP True DF tmp src2
2308 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2309 FCMP True DF src1 tmp
2311 returnNat (CondCode True cond code__2)
2313 #endif {- sparc_TARGET_ARCH -}
2315 #if powerpc_TARGET_ARCH
2317 condIntCode cond x (StInt y)
2319 = getRegister x `thenNat` \ register ->
2320 getNewRegNCG IntRep `thenNat` \ tmp ->
2322 code = registerCode register tmp
2323 src1 = registerName register tmp
2324 src2 = ImmInt (fromInteger y)
2325 code__2 = code `snocOL`
2326 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2328 returnNat (CondCode False cond code__2)
2330 condIntCode cond x y
2331 = getRegister x `thenNat` \ register1 ->
2332 getRegister y `thenNat` \ register2 ->
2333 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2334 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2336 code1 = registerCode register1 tmp1
2337 src1 = registerName register1 tmp1
2338 code2 = registerCode register2 tmp2
2339 src2 = registerName register2 tmp2
2340 code__2 = code1 `appOL` code2 `snocOL`
2341 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2343 returnNat (CondCode False cond code__2)
2345 condFltCode cond x y
2346 = getRegister x `thenNat` \ register1 ->
2347 getRegister y `thenNat` \ register2 ->
2348 getNewRegNCG (registerRep register1)
2350 getNewRegNCG (registerRep register2)
2353 code1 = registerCode register1 tmp1
2354 src1 = registerName register1 tmp1
2355 code2 = registerCode register2 tmp2
2356 src2 = registerName register2 tmp2
2357 code__2 = code1 `appOL` code2 `snocOL`
2360 returnNat (CondCode False cond code__2)
2362 #endif {- powerpc_TARGET_ARCH -}
2365 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2368 %************************************************************************
2370 \subsection{Generating assignments}
2372 %************************************************************************
2374 Assignments are really at the heart of the whole code generation
2375 business. Almost all top-level nodes of any real importance are
2376 assignments, which correspond to loads, stores, or register transfers.
2377 If we're really lucky, some of the register transfers will go away,
2378 because we can use the destination register to complete the code
2379 generation for the right hand side. This only fails when the right
2380 hand side is forced into a fixed register (e.g. the result of a call).
2383 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2384 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2386 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2387 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2389 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2391 #if alpha_TARGET_ARCH
2393 assignIntCode pk (StInd _ dst) src
2394 = getNewRegNCG IntRep `thenNat` \ tmp ->
2395 getAmode dst `thenNat` \ amode ->
2396 getRegister src `thenNat` \ register ->
2398 code1 = amodeCode amode []
2399 dst__2 = amodeAddr amode
2400 code2 = registerCode register tmp []
2401 src__2 = registerName register tmp
2402 sz = primRepToSize pk
2403 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2407 assignIntCode pk dst src
2408 = getRegister dst `thenNat` \ register1 ->
2409 getRegister src `thenNat` \ register2 ->
2411 dst__2 = registerName register1 zeroh
2412 code = registerCode register2 dst__2
2413 src__2 = registerName register2 dst__2
2414 code__2 = if isFixed register2
2415 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2420 #endif {- alpha_TARGET_ARCH -}
2422 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2424 #if i386_TARGET_ARCH
2426 -- non-FP assignment to memory
2427 assignMem_IntCode pk addr src
2428 = getAmode addr `thenNat` \ amode ->
2429 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2430 getNewRegNCG PtrRep `thenNat` \ tmp ->
2432 -- In general, if the address computation for dst may require
2433 -- some insns preceding the addressing mode itself. So there's
2434 -- no guarantee that the code for dst and the code for src won't
2435 -- write the same register. This means either the address or
2436 -- the value needs to be copied into a temporary. We detect the
2437 -- common case where the amode has no code, and elide the copy.
2438 codea = amodeCode amode
2439 dst__a = amodeAddr amode
2441 code | isNilOL codea
2443 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2446 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2448 MOV (primRepToSize pk) opsrc
2449 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2455 -> NatM (InstrBlock,Operand) -- code, operator
2458 | Just x <- maybeImm op
2459 = returnNat (nilOL, OpImm x)
2462 = getRegister op `thenNat` \ register ->
2463 getNewRegNCG (registerRep register)
2465 let code = registerCode register tmp
2466 reg = registerName register tmp
2468 returnNat (code, OpReg reg)
2470 -- Assign; dst is a reg, rhs is mem
2471 assignReg_IntCode pk reg (StInd pks src)
2472 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2473 getAmode src `thenNat` \ amode ->
2474 getRegisterReg reg `thenNat` \ reg_dst ->
2476 c_addr = amodeCode amode
2477 am_addr = amodeAddr amode
2478 r_dst = registerName reg_dst tmp
2479 szs = primRepToSize pks
2488 code = c_addr `snocOL`
2489 opc (OpAddr am_addr) (OpReg r_dst)
2493 -- dst is a reg, but src could be anything
2494 assignReg_IntCode pk reg src
2495 = getRegisterReg reg `thenNat` \ registerd ->
2496 getRegister src `thenNat` \ registers ->
2497 getNewRegNCG IntRep `thenNat` \ tmp ->
2499 r_dst = registerName registerd tmp
2500 r_src = registerName registers r_dst
2501 c_src = registerCode registers r_dst
2503 code = c_src `snocOL`
2504 MOV L (OpReg r_src) (OpReg r_dst)
2508 #endif {- i386_TARGET_ARCH -}
2510 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2512 #if sparc_TARGET_ARCH
2514 assignMem_IntCode pk addr src
2515 = getNewRegNCG IntRep `thenNat` \ tmp ->
2516 getAmode addr `thenNat` \ amode ->
2517 getRegister src `thenNat` \ register ->
2519 code1 = amodeCode amode
2520 dst__2 = amodeAddr amode
2521 code2 = registerCode register tmp
2522 src__2 = registerName register tmp
2523 sz = primRepToSize pk
2524 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2528 assignReg_IntCode pk reg src
2529 = getRegister src `thenNat` \ register2 ->
2530 getRegisterReg reg `thenNat` \ register1 ->
2531 getNewRegNCG IntRep `thenNat` \ tmp ->
2533 dst__2 = registerName register1 tmp
2534 code = registerCode register2 dst__2
2535 src__2 = registerName register2 dst__2
2536 code__2 = if isFixed register2
2537 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2542 #endif {- sparc_TARGET_ARCH -}
2544 #if powerpc_TARGET_ARCH
2546 assignMem_IntCode pk addr src
2547 = getNewRegNCG IntRep `thenNat` \ tmp ->
2548 getAmode addr `thenNat` \ amode ->
2549 getRegister src `thenNat` \ register ->
2551 code1 = amodeCode amode
2552 dst__2 = amodeAddr amode
2553 code2 = registerCode register tmp
2554 src__2 = registerName register tmp
2555 sz = primRepToSize pk
2556 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2560 assignReg_IntCode pk reg src
2561 = getRegister src `thenNat` \ register2 ->
2562 getRegisterReg reg `thenNat` \ register1 ->
2564 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2565 code = registerCode register2 dst__2
2566 src__2 = registerName register2 dst__2
2567 code__2 = if isFixed register2
2568 then code `snocOL` MR dst__2 src__2
2573 #endif {- powerpc_TARGET_ARCH -}
2575 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2578 % --------------------------------
2579 Floating-point assignments:
2580 % --------------------------------
2583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2584 #if alpha_TARGET_ARCH
2586 assignFltCode pk (StInd _ dst) src
2587 = getNewRegNCG pk `thenNat` \ tmp ->
2588 getAmode dst `thenNat` \ amode ->
2589 getRegister src `thenNat` \ register ->
2591 code1 = amodeCode amode []
2592 dst__2 = amodeAddr amode
2593 code2 = registerCode register tmp []
2594 src__2 = registerName register tmp
2595 sz = primRepToSize pk
2596 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2600 assignFltCode pk dst src
2601 = getRegister dst `thenNat` \ register1 ->
2602 getRegister src `thenNat` \ register2 ->
2604 dst__2 = registerName register1 zeroh
2605 code = registerCode register2 dst__2
2606 src__2 = registerName register2 dst__2
2607 code__2 = if isFixed register2
2608 then code . mkSeqInstr (FMOV src__2 dst__2)
2613 #endif {- alpha_TARGET_ARCH -}
2615 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2617 #if i386_TARGET_ARCH
2619 -- Floating point assignment to memory
2620 assignMem_FltCode pk addr src
2621 = getRegister src `thenNat` \ reg_src ->
2622 getRegister addr `thenNat` \ reg_addr ->
2623 getNewRegNCG pk `thenNat` \ tmp_src ->
2624 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2625 let r_src = registerName reg_src tmp_src
2626 c_src = registerCode reg_src tmp_src
2627 r_addr = registerName reg_addr tmp_addr
2628 c_addr = registerCode reg_addr tmp_addr
2629 sz = primRepToSize pk
2631 code = c_src `appOL`
2632 -- no need to preserve r_src across the addr computation,
2633 -- since r_src must be a float reg
2634 -- whilst r_addr is an int reg
2637 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2641 -- Floating point assignment to a register/temporary
2642 assignReg_FltCode pk reg src
2643 = getRegisterReg reg `thenNat` \ reg_dst ->
2644 getRegister src `thenNat` \ reg_src ->
2645 getNewRegNCG pk `thenNat` \ tmp ->
2647 r_dst = registerName reg_dst tmp
2648 r_src = registerName reg_src r_dst
2649 c_src = registerCode reg_src r_dst
2651 code = if isFixed reg_src
2652 then c_src `snocOL` GMOV r_src r_dst
2658 #endif {- i386_TARGET_ARCH -}
2660 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2662 #if sparc_TARGET_ARCH
2664 -- Floating point assignment to memory
2665 assignMem_FltCode pk addr src
2666 = getNewRegNCG pk `thenNat` \ tmp1 ->
2667 getAmode addr `thenNat` \ amode ->
2668 getRegister src `thenNat` \ register ->
2670 sz = primRepToSize pk
2671 dst__2 = amodeAddr amode
2673 code1 = amodeCode amode
2674 code2 = registerCode register tmp1
2676 src__2 = registerName register tmp1
2677 pk__2 = registerRep register
2678 sz__2 = primRepToSize pk__2
2680 code__2 = code1 `appOL` code2 `appOL`
2682 then unitOL (ST sz src__2 dst__2)
2683 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2687 -- Floating point assignment to a register/temporary
2688 -- Why is this so bizarrely ugly?
2689 assignReg_FltCode pk reg src
2690 = getRegisterReg reg `thenNat` \ register1 ->
2691 getRegister src `thenNat` \ register2 ->
2693 pk__2 = registerRep register2
2694 sz__2 = primRepToSize pk__2
2696 getNewRegNCG pk__2 `thenNat` \ tmp ->
2698 sz = primRepToSize pk
2699 dst__2 = registerName register1 g0 -- must be Fixed
2700 reg__2 = if pk /= pk__2 then tmp else dst__2
2701 code = registerCode register2 reg__2
2702 src__2 = registerName register2 reg__2
2705 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2706 else if isFixed register2 then
2707 code `snocOL` FMOV sz src__2 dst__2
2713 #endif {- sparc_TARGET_ARCH -}
2715 #if powerpc_TARGET_ARCH
2717 -- Floating point assignment to memory
2718 assignMem_FltCode pk addr src
2719 = getNewRegNCG pk `thenNat` \ tmp1 ->
2720 getAmode addr `thenNat` \ amode ->
2721 getRegister src `thenNat` \ register ->
2723 sz = primRepToSize pk
2724 dst__2 = amodeAddr amode
2726 code1 = amodeCode amode
2727 code2 = registerCode register tmp1
2729 src__2 = registerName register tmp1
2730 pk__2 = registerRep register
2731 sz__2 = primRepToSize pk__2
2733 code__2 = if pk__2 == DoubleRep || pk == pk__2
2734 then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2735 else panic "###PPC MachCode.assignMem_FltCode: FloatRep"
2736 {- code__2 = code1 `appOL` code2 `appOL`
2738 then unitOL (ST sz src__2 dst__2)
2739 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] -}
2743 -- Floating point assignment to a register/temporary
2744 assignReg_FltCode pk reg src
2745 = getRegisterReg reg `thenNat` \ reg_dst ->
2746 getRegister src `thenNat` \ reg_src ->
2747 getNewRegNCG pk `thenNat` \ tmp ->
2749 r_dst = registerName reg_dst tmp
2750 r_src = registerName reg_src r_dst
2751 c_src = registerCode reg_src r_dst
2753 code = if isFixed reg_src
2754 then c_src `snocOL` MR r_dst r_src
2758 #endif {- powerpc_TARGET_ARCH -}
2760 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2763 %************************************************************************
2765 \subsection{Generating an unconditional branch}
2767 %************************************************************************
2769 We accept two types of targets: an immediate CLabel or a tree that
2770 gets evaluated into a register. Any CLabels which are AsmTemporaries
2771 are assumed to be in the local block of code, close enough for a
2772 branch instruction. Other CLabels are assumed to be far away.
2774 (If applicable) Do not fill the delay slots here; you will confuse the
2778 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2780 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2782 #if alpha_TARGET_ARCH
2784 genJump (StCLbl lbl)
2785 | isAsmTemp lbl = returnInstr (BR target)
2786 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2788 target = ImmCLbl lbl
2791 = getRegister tree `thenNat` \ register ->
2792 getNewRegNCG PtrRep `thenNat` \ tmp ->
2794 dst = registerName register pv
2795 code = registerCode register pv
2796 target = registerName register pv
2798 if isFixed register then
2799 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2801 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2803 #endif {- alpha_TARGET_ARCH -}
2805 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2807 #if i386_TARGET_ARCH
2809 genJump dsts (StInd pk mem)
2810 = getAmode mem `thenNat` \ amode ->
2812 code = amodeCode amode
2813 target = amodeAddr amode
2815 returnNat (code `snocOL` JMP dsts (OpAddr target))
2819 = returnNat (unitOL (JMP dsts (OpImm target)))
2822 = getRegister tree `thenNat` \ register ->
2823 getNewRegNCG PtrRep `thenNat` \ tmp ->
2825 code = registerCode register tmp
2826 target = registerName register tmp
2828 returnNat (code `snocOL` JMP dsts (OpReg target))
2831 target = case imm of Just x -> x
2833 #endif {- i386_TARGET_ARCH -}
2835 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2837 #if sparc_TARGET_ARCH
2839 genJump dsts (StCLbl lbl)
2840 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2841 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2842 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2844 target = ImmCLbl lbl
2847 = getRegister tree `thenNat` \ register ->
2848 getNewRegNCG PtrRep `thenNat` \ tmp ->
2850 code = registerCode register tmp
2851 target = registerName register tmp
2853 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2855 #endif {- sparc_TARGET_ARCH -}
2857 #if powerpc_TARGET_ARCH
2858 genJump dsts (StCLbl lbl)
2859 = returnNat (toOL [BCC ALWAYS lbl])
2862 = getRegister tree `thenNat` \ register ->
2863 getNewRegNCG PtrRep `thenNat` \ tmp ->
2865 code = registerCode register tmp
2866 target = registerName register tmp
2868 returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
2869 #endif {- sparc_TARGET_ARCH -}
2871 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2873 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2876 %************************************************************************
2878 \subsection{Conditional jumps}
2880 %************************************************************************
2882 Conditional jumps are always to local labels, so we can use branch
2883 instructions. We peek at the arguments to decide what kind of
2886 ALPHA: For comparisons with 0, we're laughing, because we can just do
2887 the desired conditional branch.
2889 I386: First, we have to ensure that the condition
2890 codes are set according to the supplied comparison operation.
2892 SPARC: First, we have to ensure that the condition codes are set
2893 according to the supplied comparison operation. We generate slightly
2894 different code for floating point comparisons, because a floating
2895 point operation cannot directly precede a @BF@. We assume the worst
2896 and fill that slot with a @NOP@.
2898 SPARC: Do not fill the delay slots here; you will confuse the register
2903 :: CLabel -- the branch target
2904 -> StixExpr -- the condition on which to branch
2907 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2909 #if alpha_TARGET_ARCH
2911 genCondJump lbl (StPrim op [x, StInt 0])
2912 = getRegister x `thenNat` \ register ->
2913 getNewRegNCG (registerRep register)
2916 code = registerCode register tmp
2917 value = registerName register tmp
2918 pk = registerRep register
2919 target = ImmCLbl lbl
2921 returnSeq code [BI (cmpOp op) value target]
2923 cmpOp CharGtOp = GTT
2925 cmpOp CharEqOp = EQQ
2927 cmpOp CharLtOp = LTT
2936 cmpOp WordGeOp = ALWAYS
2937 cmpOp WordEqOp = EQQ
2939 cmpOp WordLtOp = NEVER
2940 cmpOp WordLeOp = EQQ
2942 cmpOp AddrGeOp = ALWAYS
2943 cmpOp AddrEqOp = EQQ
2945 cmpOp AddrLtOp = NEVER
2946 cmpOp AddrLeOp = EQQ
2948 genCondJump lbl (StPrim op [x, StDouble 0.0])
2949 = getRegister x `thenNat` \ register ->
2950 getNewRegNCG (registerRep register)
2953 code = registerCode register tmp
2954 value = registerName register tmp
2955 pk = registerRep register
2956 target = ImmCLbl lbl
2958 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2960 cmpOp FloatGtOp = GTT
2961 cmpOp FloatGeOp = GE
2962 cmpOp FloatEqOp = EQQ
2963 cmpOp FloatNeOp = NE
2964 cmpOp FloatLtOp = LTT
2965 cmpOp FloatLeOp = LE
2966 cmpOp DoubleGtOp = GTT
2967 cmpOp DoubleGeOp = GE
2968 cmpOp DoubleEqOp = EQQ
2969 cmpOp DoubleNeOp = NE
2970 cmpOp DoubleLtOp = LTT
2971 cmpOp DoubleLeOp = LE
2973 genCondJump lbl (StPrim op [x, y])
2975 = trivialFCode pr instr x y `thenNat` \ register ->
2976 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2978 code = registerCode register tmp
2979 result = registerName register tmp
2980 target = ImmCLbl lbl
2982 returnNat (code . mkSeqInstr (BF cond result target))
2984 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2986 fltCmpOp op = case op of
3000 (instr, cond) = case op of
3001 FloatGtOp -> (FCMP TF LE, EQQ)
3002 FloatGeOp -> (FCMP TF LTT, EQQ)
3003 FloatEqOp -> (FCMP TF EQQ, NE)
3004 FloatNeOp -> (FCMP TF EQQ, EQQ)
3005 FloatLtOp -> (FCMP TF LTT, NE)
3006 FloatLeOp -> (FCMP TF LE, NE)
3007 DoubleGtOp -> (FCMP TF LE, EQQ)
3008 DoubleGeOp -> (FCMP TF LTT, EQQ)
3009 DoubleEqOp -> (FCMP TF EQQ, NE)
3010 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3011 DoubleLtOp -> (FCMP TF LTT, NE)
3012 DoubleLeOp -> (FCMP TF LE, NE)
3014 genCondJump lbl (StPrim op [x, y])
3015 = trivialCode instr x y `thenNat` \ register ->
3016 getNewRegNCG IntRep `thenNat` \ tmp ->
3018 code = registerCode register tmp
3019 result = registerName register tmp
3020 target = ImmCLbl lbl
3022 returnNat (code . mkSeqInstr (BI cond result target))
3024 (instr, cond) = case op of
3025 CharGtOp -> (CMP LE, EQQ)
3026 CharGeOp -> (CMP LTT, EQQ)
3027 CharEqOp -> (CMP EQQ, NE)
3028 CharNeOp -> (CMP EQQ, EQQ)
3029 CharLtOp -> (CMP LTT, NE)
3030 CharLeOp -> (CMP LE, NE)
3031 IntGtOp -> (CMP LE, EQQ)
3032 IntGeOp -> (CMP LTT, EQQ)
3033 IntEqOp -> (CMP EQQ, NE)
3034 IntNeOp -> (CMP EQQ, EQQ)
3035 IntLtOp -> (CMP LTT, NE)
3036 IntLeOp -> (CMP LE, NE)
3037 WordGtOp -> (CMP ULE, EQQ)
3038 WordGeOp -> (CMP ULT, EQQ)
3039 WordEqOp -> (CMP EQQ, NE)
3040 WordNeOp -> (CMP EQQ, EQQ)
3041 WordLtOp -> (CMP ULT, NE)
3042 WordLeOp -> (CMP ULE, NE)
3043 AddrGtOp -> (CMP ULE, EQQ)
3044 AddrGeOp -> (CMP ULT, EQQ)
3045 AddrEqOp -> (CMP EQQ, NE)
3046 AddrNeOp -> (CMP EQQ, EQQ)
3047 AddrLtOp -> (CMP ULT, NE)
3048 AddrLeOp -> (CMP ULE, NE)
3050 #endif {- alpha_TARGET_ARCH -}
3052 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3054 #if i386_TARGET_ARCH
3056 genCondJump lbl bool
3057 = getCondCode bool `thenNat` \ condition ->
3059 code = condCode condition
3060 cond = condName condition
3062 returnNat (code `snocOL` JXX cond lbl)
3064 #endif {- i386_TARGET_ARCH -}
3066 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3068 #if sparc_TARGET_ARCH
3070 genCondJump lbl bool
3071 = getCondCode bool `thenNat` \ condition ->
3073 code = condCode condition
3074 cond = condName condition
3075 target = ImmCLbl lbl
3080 if condFloat condition
3081 then [NOP, BF cond False target, NOP]
3082 else [BI cond False target, NOP]
3086 #endif {- sparc_TARGET_ARCH -}
3088 #if powerpc_TARGET_ARCH
3090 genCondJump lbl bool
3091 = getCondCode bool `thenNat` \ condition ->
3093 code = condCode condition
3094 cond = condName condition
3095 target = ImmCLbl lbl
3098 code `snocOL` BCC cond lbl )
3100 #endif {- powerpc_TARGET_ARCH -}
3102 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3107 %************************************************************************
3109 \subsection{Generating C calls}
3111 %************************************************************************
3113 Now the biggest nightmare---calls. Most of the nastiness is buried in
3114 @get_arg@, which moves the arguments to the correct registers/stack
3115 locations. Apart from that, the code is easy.
3117 (If applicable) Do not fill the delay slots here; you will confuse the
3122 :: (Either FastString StixExpr) -- function to call
3124 -> PrimRep -- type of the result
3125 -> [StixExpr] -- arguments (of mixed type)
3128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3130 #if alpha_TARGET_ARCH
3132 genCCall fn cconv kind args
3133 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3134 `thenNat` \ ((unused,_), argCode) ->
3136 nRegs = length allArgRegs - length unused
3137 code = asmSeqThen (map ($ []) argCode)
3140 LDA pv (AddrImm (ImmLab (ptext fn))),
3141 JSR ra (AddrReg pv) nRegs,
3142 LDGP gp (AddrReg ra)]
3144 ------------------------
3145 {- Try to get a value into a specific register (or registers) for
3146 a call. The first 6 arguments go into the appropriate
3147 argument register (separate registers for integer and floating
3148 point arguments, but used in lock-step), and the remaining
3149 arguments are dumped to the stack, beginning at 0(sp). Our
3150 first argument is a pair of the list of remaining argument
3151 registers to be assigned for this call and the next stack
3152 offset to use for overflowing arguments. This way,
3153 @get_Arg@ can be applied to all of a call's arguments using
3157 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3158 -> StixTree -- Current argument
3159 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3161 -- We have to use up all of our argument registers first...
3163 get_arg ((iDst,fDst):dsts, offset) arg
3164 = getRegister arg `thenNat` \ register ->
3166 reg = if isFloatingRep pk then fDst else iDst
3167 code = registerCode register reg
3168 src = registerName register reg
3169 pk = registerRep register
3172 if isFloatingRep pk then
3173 ((dsts, offset), if isFixed register then
3174 code . mkSeqInstr (FMOV src fDst)
3177 ((dsts, offset), if isFixed register then
3178 code . mkSeqInstr (OR src (RIReg src) iDst)
3181 -- Once we have run out of argument registers, we move to the
3184 get_arg ([], offset) arg
3185 = getRegister arg `thenNat` \ register ->
3186 getNewRegNCG (registerRep register)
3189 code = registerCode register tmp
3190 src = registerName register tmp
3191 pk = registerRep register
3192 sz = primRepToSize pk
3194 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3196 #endif {- alpha_TARGET_ARCH -}
3198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3200 #if i386_TARGET_ARCH
3202 genCCall fn cconv ret_rep args
3204 (reverse args) `thenNat` \ sizes_n_codes ->
3205 getDeltaNat `thenNat` \ delta ->
3206 let (sizes, push_codes) = unzip sizes_n_codes
3207 tot_arg_size = sum sizes
3209 -- deal with static vs dynamic call targets
3212 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3214 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3215 ASSERT(case dyn_rep of { L -> True; _ -> False})
3216 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3218 `thenNat` \ callinsns ->
3219 let push_code = concatOL push_codes
3220 call = callinsns `appOL`
3222 -- Deallocate parameters after call for ccall;
3223 -- but not for stdcall (callee does it)
3224 (if cconv == StdCallConv then [] else
3225 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3227 [DELTA (delta + tot_arg_size)]
3230 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3231 returnNat (push_code `appOL` call)
3234 -- function names that begin with '.' are assumed to be special
3235 -- internally generated names like '.mul,' which don't get an
3236 -- underscore prefix
3237 -- ToDo:needed (WDP 96/03) ???
3238 fn_u = unpackFS (unLeft fn)
3241 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3242 | otherwise -- General case
3243 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3245 stdcallsize tot_arg_size
3246 | cconv == StdCallConv = '@':show tot_arg_size
3254 push_arg :: StixExpr{-current argument-}
3255 -> NatM (Int, InstrBlock) -- argsz, code
3258 | is64BitRep arg_rep
3259 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3260 getDeltaNat `thenNat` \ delta ->
3261 setDeltaNat (delta - 8) `thenNat` \ _ ->
3262 let r_lo = VirtualRegI vr_lo
3263 r_hi = getHiVRegFromLo r_lo
3266 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3267 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3270 = get_op arg `thenNat` \ (code, reg, sz) ->
3271 getDeltaNat `thenNat` \ delta ->
3272 arg_size sz `bind` \ size ->
3273 setDeltaNat (delta-size) `thenNat` \ _ ->
3274 if (case sz of DF -> True; F -> True; _ -> False)
3275 then returnNat (size,
3277 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3279 GST sz reg (AddrBaseIndex (Just esp)
3283 else returnNat (size,
3285 PUSH L (OpReg reg) `snocOL`
3289 arg_rep = repOfStixExpr arg
3294 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3297 = getRegister op `thenNat` \ register ->
3298 getNewRegNCG (registerRep register)
3301 code = registerCode register tmp
3302 reg = registerName register tmp
3303 pk = registerRep register
3304 sz = primRepToSize pk
3306 returnNat (code, reg, sz)
3308 #endif {- i386_TARGET_ARCH -}
3310 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3312 #if sparc_TARGET_ARCH
3314 The SPARC calling convention is an absolute
3315 nightmare. The first 6x32 bits of arguments are mapped into
3316 %o0 through %o5, and the remaining arguments are dumped to the
3317 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3319 If we have to put args on the stack, move %o6==%sp down by
3320 the number of words to go on the stack, to ensure there's enough space.
3322 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3323 16 words above the stack pointer is a word for the address of
3324 a structure return value. I use this as a temporary location
3325 for moving values from float to int regs. Certainly it isn't
3326 safe to put anything in the 16 words starting at %sp, since
3327 this area can get trashed at any time due to window overflows
3328 caused by signal handlers.
3330 A final complication (if the above isn't enough) is that
3331 we can't blithely calculate the arguments one by one into
3332 %o0 .. %o5. Consider the following nested calls:
3336 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3337 the inner call will itself use %o0, which trashes the value put there
3338 in preparation for the outer call. Upshot: we need to calculate the
3339 args into temporary regs, and move those to arg regs or onto the
3340 stack only immediately prior to the call proper. Sigh.
3343 genCCall fn cconv kind args
3344 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3346 (argcodes, vregss) = unzip argcode_and_vregs
3347 n_argRegs = length allArgRegs
3348 n_argRegs_used = min (length vregs) n_argRegs
3349 vregs = concat vregss
3351 -- deal with static vs dynamic call targets
3354 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3356 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3357 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3359 `thenNat` \ callinsns ->
3361 argcode = concatOL argcodes
3362 (move_sp_down, move_sp_up)
3363 = let diff = length vregs - n_argRegs
3364 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3367 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3369 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3371 returnNat (argcode `appOL`
3372 move_sp_down `appOL`
3373 transfer_code `appOL`
3378 -- function names that begin with '.' are assumed to be special
3379 -- internally generated names like '.mul,' which don't get an
3380 -- underscore prefix
3381 -- ToDo:needed (WDP 96/03) ???
3382 fn_static = unLeft fn
3383 fn__2 = case (headFS fn_static) of
3384 '.' -> ImmLit (ftext fn_static)
3385 _ -> ImmLab False (ftext fn_static)
3387 -- move args from the integer vregs into which they have been
3388 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3389 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3391 move_final [] _ offset -- all args done
3394 move_final (v:vs) [] offset -- out of aregs; move to stack
3395 = ST W v (spRel offset)
3396 : move_final vs [] (offset+1)
3398 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3399 = OR False g0 (RIReg v) a
3400 : move_final vs az offset
3402 -- generate code to calculate an argument, and move it into one
3403 -- or two integer vregs.
3404 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3405 arg_to_int_vregs arg
3406 | is64BitRep (repOfStixExpr arg)
3407 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3408 let r_lo = VirtualRegI vr_lo
3409 r_hi = getHiVRegFromLo r_lo
3410 in returnNat (code, [r_hi, r_lo])
3412 = getRegister arg `thenNat` \ register ->
3413 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3414 let code = registerCode register tmp
3415 src = registerName register tmp
3416 pk = registerRep register
3418 -- the value is in src. Get it into 1 or 2 int vregs.
3421 getNewRegNCG WordRep `thenNat` \ v1 ->
3422 getNewRegNCG WordRep `thenNat` \ v2 ->
3425 FMOV DF src f0 `snocOL`
3426 ST F f0 (spRel 16) `snocOL`
3427 LD W (spRel 16) v1 `snocOL`
3428 ST F (fPair f0) (spRel 16) `snocOL`
3434 getNewRegNCG WordRep `thenNat` \ v1 ->
3437 ST F src (spRel 16) `snocOL`
3443 getNewRegNCG WordRep `thenNat` \ v1 ->
3445 code `snocOL` OR False g0 (RIReg src) v1
3449 #endif {- sparc_TARGET_ARCH -}
3451 #if powerpc_TARGET_ARCH
3453 The PowerPC calling convention (at least for Darwin/Mac OS X)
3454 is described in Apple's document
3455 "Inside Mac OS X - Mach-O Runtime Architecture".
3456 Parameters may be passed in general-purpose registers, in
3457 floating point registers, or on the stack. Stack space is
3458 always reserved for parameters, even if they are passed in registers.
3459 The called routine may choose to save parameters from registers
3460 to the corresponding space on the stack.
3461 The parameter area should be part of the caller's stack frame,
3462 allocated in the caller's prologue code (large enough to hold
3463 the parameter lists for all called routines). The NCG already
3464 uses the space that we should use as a parameter area for register
3465 spilling, so we allocate a new stack frame just before ccalling.
3466 That way we don't need to decide beforehand how much space to
3467 reserve for parameters.
3470 genCCall fn cconv kind args
3471 = mapNat prepArg args `thenNat` \ preppedArgs ->
3473 (argReps,argCodes,vregs) = unzip3 preppedArgs
3475 -- size of linkage area + size of arguments, in bytes
3476 stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3477 roundTo16 x | x `mod` 16 == 0 = x
3478 | otherwise = x + 16 - (x `mod` 16)
3480 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3481 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3483 (moveFinalCode,usedRegs) = move_final
3485 allArgRegs allFPArgRegs
3489 passArguments = concatOL argCodes
3490 `appOL` move_sp_down
3491 `appOL` moveFinalCode
3494 Left lbl -> returnNat ( passArguments
3495 `snocOL` BL (ImmLab False (ftext lbl)) usedRegs
3498 getRegister dyn `thenNat` \ dynReg ->
3499 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3500 returnNat (registerCode dynReg tmp
3501 `appOL` passArguments
3502 `snocOL` MTCTR (registerName dynReg tmp)
3503 `snocOL` BCTRL usedRegs
3507 | is64BitRep (repOfStixExpr arg)
3508 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3509 let r_lo = VirtualRegI vr_lo
3510 r_hi = getHiVRegFromLo r_lo
3511 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3513 = getRegister arg `thenNat` \ register ->
3514 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3515 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3516 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3517 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3518 | not (is64BitRep rep) =
3521 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3524 fpr : fprs -> MR fpr vr
3525 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3526 ((take 1 fprs) ++ accumUsed)
3528 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3531 fpr : fprs -> MR fpr vr
3532 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3533 ((take 1 fprs) ++ accumUsed)
3534 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3536 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3539 gpr : gprs -> MR gpr vr
3540 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3541 ((take 1 gprs) ++ accumUsed)
3543 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3546 storeWord vr (gpr:_) offset = MR gpr vr
3547 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3549 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3551 `snocOL` storeWord vr_hi gprs stackOffset
3552 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3553 ((take 2 gprs) ++ accumUsed)
3554 #endif {- powerpc_TARGET_ARCH -}
3556 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3559 %************************************************************************
3561 \subsection{Support bits}
3563 %************************************************************************
3565 %************************************************************************
3567 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3569 %************************************************************************
3571 Turn those condition codes into integers now (when they appear on
3572 the right hand side of an assignment).
3574 (If applicable) Do not fill the delay slots here; you will confuse the
3578 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3580 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3582 #if alpha_TARGET_ARCH
3583 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3584 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3585 #endif {- alpha_TARGET_ARCH -}
3587 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3589 #if i386_TARGET_ARCH
3592 = condIntCode cond x y `thenNat` \ condition ->
3593 getNewRegNCG IntRep `thenNat` \ tmp ->
3595 code = condCode condition
3596 cond = condName condition
3597 code__2 dst = code `appOL` toOL [
3598 SETCC cond (OpReg tmp),
3599 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3600 MOV L (OpReg tmp) (OpReg dst)]
3602 returnNat (Any IntRep code__2)
3605 = getNatLabelNCG `thenNat` \ lbl1 ->
3606 getNatLabelNCG `thenNat` \ lbl2 ->
3607 condFltCode cond x y `thenNat` \ condition ->
3609 code = condCode condition
3610 cond = condName condition
3611 code__2 dst = code `appOL` toOL [
3613 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3616 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3619 returnNat (Any IntRep code__2)
3621 #endif {- i386_TARGET_ARCH -}
3623 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3625 #if sparc_TARGET_ARCH
3627 condIntReg EQQ x (StInt 0)
3628 = getRegister x `thenNat` \ register ->
3629 getNewRegNCG IntRep `thenNat` \ tmp ->
3631 code = registerCode register tmp
3632 src = registerName register tmp
3633 code__2 dst = code `appOL` toOL [
3634 SUB False True g0 (RIReg src) g0,
3635 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3637 returnNat (Any IntRep code__2)
3640 = getRegister x `thenNat` \ register1 ->
3641 getRegister y `thenNat` \ register2 ->
3642 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3643 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3645 code1 = registerCode register1 tmp1
3646 src1 = registerName register1 tmp1
3647 code2 = registerCode register2 tmp2
3648 src2 = registerName register2 tmp2
3649 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3650 XOR False src1 (RIReg src2) dst,
3651 SUB False True g0 (RIReg dst) g0,
3652 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3654 returnNat (Any IntRep code__2)
3656 condIntReg NE x (StInt 0)
3657 = getRegister x `thenNat` \ register ->
3658 getNewRegNCG IntRep `thenNat` \ tmp ->
3660 code = registerCode register tmp
3661 src = registerName register tmp
3662 code__2 dst = code `appOL` toOL [
3663 SUB False True g0 (RIReg src) g0,
3664 ADD True False g0 (RIImm (ImmInt 0)) dst]
3666 returnNat (Any IntRep code__2)
3669 = getRegister x `thenNat` \ register1 ->
3670 getRegister y `thenNat` \ register2 ->
3671 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3672 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3674 code1 = registerCode register1 tmp1
3675 src1 = registerName register1 tmp1
3676 code2 = registerCode register2 tmp2
3677 src2 = registerName register2 tmp2
3678 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3679 XOR False src1 (RIReg src2) dst,
3680 SUB False True g0 (RIReg dst) g0,
3681 ADD True False g0 (RIImm (ImmInt 0)) dst]
3683 returnNat (Any IntRep code__2)
3686 = getNatLabelNCG `thenNat` \ lbl1 ->
3687 getNatLabelNCG `thenNat` \ lbl2 ->
3688 condIntCode cond x y `thenNat` \ condition ->
3690 code = condCode condition
3691 cond = condName condition
3692 code__2 dst = code `appOL` toOL [
3693 BI cond False (ImmCLbl lbl1), NOP,
3694 OR False g0 (RIImm (ImmInt 0)) dst,
3695 BI ALWAYS False (ImmCLbl lbl2), NOP,
3697 OR False g0 (RIImm (ImmInt 1)) dst,
3700 returnNat (Any IntRep code__2)
3703 = getNatLabelNCG `thenNat` \ lbl1 ->
3704 getNatLabelNCG `thenNat` \ lbl2 ->
3705 condFltCode cond x y `thenNat` \ condition ->
3707 code = condCode condition
3708 cond = condName condition
3709 code__2 dst = code `appOL` toOL [
3711 BF cond False (ImmCLbl lbl1), NOP,
3712 OR False g0 (RIImm (ImmInt 0)) dst,
3713 BI ALWAYS False (ImmCLbl lbl2), NOP,
3715 OR False g0 (RIImm (ImmInt 1)) dst,
3718 returnNat (Any IntRep code__2)
3720 #endif {- sparc_TARGET_ARCH -}
3722 #if powerpc_TARGET_ARCH
3724 = getNatLabelNCG `thenNat` \ lbl ->
3725 condIntCode cond x y `thenNat` \ condition ->
3727 code = condCode condition
3728 cond = condName condition
3729 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3734 returnNat (Any IntRep code__2)
3737 = getNatLabelNCG `thenNat` \ lbl ->
3738 condFltCode cond x y `thenNat` \ condition ->
3740 code = condCode condition
3741 cond = condName condition
3742 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3747 returnNat (Any IntRep code__2)
3748 #endif {- powerpc_TARGET_ARCH -}
3750 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3753 %************************************************************************
3755 \subsubsection{@trivial*Code@: deal with trivial instructions}
3757 %************************************************************************
3759 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3760 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3761 for constants on the right hand side, because that's where the generic
3762 optimizer will have put them.
3764 Similarly, for unary instructions, we don't have to worry about
3765 matching an StInt as the argument, because genericOpt will already
3766 have handled the constant-folding.
3770 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3771 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3772 -> Maybe (Operand -> Operand -> Instr)
3773 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3774 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3776 -> StixExpr -> StixExpr -- the two arguments
3781 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3782 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3783 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3784 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3786 -> StixExpr -> StixExpr -- the two arguments
3790 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3791 ,IF_ARCH_i386 ((Operand -> Instr)
3792 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3793 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3795 -> StixExpr -- the one argument
3800 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3801 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3802 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3803 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3805 -> StixExpr -- the one argument
3808 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3810 #if alpha_TARGET_ARCH
3812 trivialCode instr x (StInt y)
3814 = getRegister x `thenNat` \ register ->
3815 getNewRegNCG IntRep `thenNat` \ tmp ->
3817 code = registerCode register tmp
3818 src1 = registerName register tmp
3819 src2 = ImmInt (fromInteger y)
3820 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3822 returnNat (Any IntRep code__2)
3824 trivialCode instr x y
3825 = getRegister x `thenNat` \ register1 ->
3826 getRegister y `thenNat` \ register2 ->
3827 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3828 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3830 code1 = registerCode register1 tmp1 []
3831 src1 = registerName register1 tmp1
3832 code2 = registerCode register2 tmp2 []
3833 src2 = registerName register2 tmp2
3834 code__2 dst = asmSeqThen [code1, code2] .
3835 mkSeqInstr (instr src1 (RIReg src2) dst)
3837 returnNat (Any IntRep code__2)
3840 trivialUCode instr x
3841 = getRegister x `thenNat` \ register ->
3842 getNewRegNCG IntRep `thenNat` \ tmp ->
3844 code = registerCode register tmp
3845 src = registerName register tmp
3846 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3848 returnNat (Any IntRep code__2)
3851 trivialFCode _ instr x y
3852 = getRegister x `thenNat` \ register1 ->
3853 getRegister y `thenNat` \ register2 ->
3854 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3855 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3857 code1 = registerCode register1 tmp1
3858 src1 = registerName register1 tmp1
3860 code2 = registerCode register2 tmp2
3861 src2 = registerName register2 tmp2
3863 code__2 dst = asmSeqThen [code1 [], code2 []] .
3864 mkSeqInstr (instr src1 src2 dst)
3866 returnNat (Any DoubleRep code__2)
3868 trivialUFCode _ instr x
3869 = getRegister x `thenNat` \ register ->
3870 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3872 code = registerCode register tmp
3873 src = registerName register tmp
3874 code__2 dst = code . mkSeqInstr (instr src dst)
3876 returnNat (Any DoubleRep code__2)
3878 #endif {- alpha_TARGET_ARCH -}
3880 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3882 #if i386_TARGET_ARCH
3884 The Rules of the Game are:
3886 * You cannot assume anything about the destination register dst;
3887 it may be anything, including a fixed reg.
3889 * You may compute an operand into a fixed reg, but you may not
3890 subsequently change the contents of that fixed reg. If you
3891 want to do so, first copy the value either to a temporary
3892 or into dst. You are free to modify dst even if it happens
3893 to be a fixed reg -- that's not your problem.
3895 * You cannot assume that a fixed reg will stay live over an
3896 arbitrary computation. The same applies to the dst reg.
3898 * Temporary regs obtained from getNewRegNCG are distinct from
3899 each other and from all other regs, and stay live over
3900 arbitrary computations.
3904 trivialCode instr maybe_revinstr a b
3907 = getRegister a `thenNat` \ rega ->
3910 then registerCode rega dst `bind` \ code_a ->
3912 instr (OpImm imm_b) (OpReg dst)
3913 else registerCodeF rega `bind` \ code_a ->
3914 registerNameF rega `bind` \ r_a ->
3916 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3917 instr (OpImm imm_b) (OpReg dst)
3919 returnNat (Any IntRep mkcode)
3922 = getRegister b `thenNat` \ regb ->
3923 getNewRegNCG IntRep `thenNat` \ tmp ->
3924 let revinstr_avail = maybeToBool maybe_revinstr
3925 revinstr = case maybe_revinstr of Just ri -> ri
3929 then registerCode regb dst `bind` \ code_b ->
3931 revinstr (OpImm imm_a) (OpReg dst)
3932 else registerCodeF regb `bind` \ code_b ->
3933 registerNameF regb `bind` \ r_b ->
3935 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3936 revinstr (OpImm imm_a) (OpReg dst)
3940 then registerCode regb tmp `bind` \ code_b ->
3942 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3943 instr (OpReg tmp) (OpReg dst)
3944 else registerCodeF regb `bind` \ code_b ->
3945 registerNameF regb `bind` \ r_b ->
3947 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3948 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3949 instr (OpReg tmp) (OpReg dst)
3951 returnNat (Any IntRep mkcode)
3954 = getRegister a `thenNat` \ rega ->
3955 getRegister b `thenNat` \ regb ->
3956 getNewRegNCG IntRep `thenNat` \ tmp ->
3958 = case (isAny rega, isAny regb) of
3960 -> registerCode regb tmp `bind` \ code_b ->
3961 registerCode rega dst `bind` \ code_a ->
3964 instr (OpReg tmp) (OpReg dst)
3966 -> registerCode rega tmp `bind` \ code_a ->
3967 registerCodeF regb `bind` \ code_b ->
3968 registerNameF regb `bind` \ r_b ->
3971 instr (OpReg r_b) (OpReg tmp) `snocOL`
3972 MOV L (OpReg tmp) (OpReg dst)
3974 -> registerCode regb tmp `bind` \ code_b ->
3975 registerCodeF rega `bind` \ code_a ->
3976 registerNameF rega `bind` \ r_a ->
3979 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3980 instr (OpReg tmp) (OpReg dst)
3982 -> registerCodeF rega `bind` \ code_a ->
3983 registerNameF rega `bind` \ r_a ->
3984 registerCodeF regb `bind` \ code_b ->
3985 registerNameF regb `bind` \ r_b ->
3987 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3989 instr (OpReg r_b) (OpReg tmp) `snocOL`
3990 MOV L (OpReg tmp) (OpReg dst)
3992 returnNat (Any IntRep mkcode)
3995 maybe_imm_a = maybeImm a
3996 is_imm_a = maybeToBool maybe_imm_a
3997 imm_a = case maybe_imm_a of Just imm -> imm
3999 maybe_imm_b = maybeImm b
4000 is_imm_b = maybeToBool maybe_imm_b
4001 imm_b = case maybe_imm_b of Just imm -> imm
4005 trivialUCode instr x
4006 = getRegister x `thenNat` \ register ->
4008 code__2 dst = let code = registerCode register dst
4009 src = registerName register dst
4011 if isFixed register && dst /= src
4012 then toOL [MOV L (OpReg src) (OpReg dst),
4014 else unitOL (instr (OpReg src))
4016 returnNat (Any IntRep code__2)
4019 trivialFCode pk instr x y
4020 = getRegister x `thenNat` \ register1 ->
4021 getRegister y `thenNat` \ register2 ->
4022 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4023 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4025 code1 = registerCode register1 tmp1
4026 src1 = registerName register1 tmp1
4028 code2 = registerCode register2 tmp2
4029 src2 = registerName register2 tmp2
4032 -- treat the common case specially: both operands in
4034 | isAny register1 && isAny register2
4037 instr (primRepToSize pk) src1 src2 dst
4039 -- be paranoid (and inefficient)
4041 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4043 instr (primRepToSize pk) tmp1 src2 dst
4045 returnNat (Any pk code__2)
4049 trivialUFCode pk instr x
4050 = getRegister x `thenNat` \ register ->
4051 getNewRegNCG pk `thenNat` \ tmp ->
4053 code = registerCode register tmp
4054 src = registerName register tmp
4055 code__2 dst = code `snocOL` instr src dst
4057 returnNat (Any pk code__2)
4059 #endif {- i386_TARGET_ARCH -}
4061 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4063 #if sparc_TARGET_ARCH
4065 trivialCode instr x (StInt y)
4067 = getRegister x `thenNat` \ register ->
4068 getNewRegNCG IntRep `thenNat` \ tmp ->
4070 code = registerCode register tmp
4071 src1 = registerName register tmp
4072 src2 = ImmInt (fromInteger y)
4073 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4075 returnNat (Any IntRep code__2)
4077 trivialCode instr x y
4078 = getRegister x `thenNat` \ register1 ->
4079 getRegister y `thenNat` \ register2 ->
4080 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4081 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4083 code1 = registerCode register1 tmp1
4084 src1 = registerName register1 tmp1
4085 code2 = registerCode register2 tmp2
4086 src2 = registerName register2 tmp2
4087 code__2 dst = code1 `appOL` code2 `snocOL`
4088 instr src1 (RIReg src2) dst
4090 returnNat (Any IntRep code__2)
4093 trivialFCode pk instr x y
4094 = getRegister x `thenNat` \ register1 ->
4095 getRegister y `thenNat` \ register2 ->
4096 getNewRegNCG (registerRep register1)
4098 getNewRegNCG (registerRep register2)
4100 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4102 promote x = FxTOy F DF x tmp
4104 pk1 = registerRep register1
4105 code1 = registerCode register1 tmp1
4106 src1 = registerName register1 tmp1
4108 pk2 = registerRep register2
4109 code2 = registerCode register2 tmp2
4110 src2 = registerName register2 tmp2
4114 code1 `appOL` code2 `snocOL`
4115 instr (primRepToSize pk) src1 src2 dst
4116 else if pk1 == FloatRep then
4117 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4118 instr DF tmp src2 dst
4120 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4121 instr DF src1 tmp dst
4123 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4126 trivialUCode instr x
4127 = getRegister x `thenNat` \ register ->
4128 getNewRegNCG IntRep `thenNat` \ tmp ->
4130 code = registerCode register tmp
4131 src = registerName register tmp
4132 code__2 dst = code `snocOL` instr (RIReg src) dst
4134 returnNat (Any IntRep code__2)
4137 trivialUFCode pk instr x
4138 = getRegister x `thenNat` \ register ->
4139 getNewRegNCG pk `thenNat` \ tmp ->
4141 code = registerCode register tmp
4142 src = registerName register tmp
4143 code__2 dst = code `snocOL` instr src dst
4145 returnNat (Any pk code__2)
4147 #endif {- sparc_TARGET_ARCH -}
4149 #if powerpc_TARGET_ARCH
4150 trivialCode instr x (StInt y)
4152 = getRegister x `thenNat` \ register ->
4153 getNewRegNCG IntRep `thenNat` \ tmp ->
4155 code = registerCode register tmp
4156 src1 = registerName register tmp
4157 src2 = ImmInt (fromInteger y)
4158 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4160 returnNat (Any IntRep code__2)
4162 trivialCode instr x y
4163 = getRegister x `thenNat` \ register1 ->
4164 getRegister y `thenNat` \ register2 ->
4165 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4166 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4168 code1 = registerCode register1 tmp1
4169 src1 = registerName register1 tmp1
4170 code2 = registerCode register2 tmp2
4171 src2 = registerName register2 tmp2
4172 code__2 dst = code1 `appOL` code2 `snocOL`
4173 instr dst src1 (RIReg src2)
4175 returnNat (Any IntRep code__2)
4177 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4178 -> StixExpr -> StixExpr -> NatM Register
4179 trivialCode2 instr x y
4180 = getRegister x `thenNat` \ register1 ->
4181 getRegister y `thenNat` \ register2 ->
4182 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4183 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4185 code1 = registerCode register1 tmp1
4186 src1 = registerName register1 tmp1
4187 code2 = registerCode register2 tmp2
4188 src2 = registerName register2 tmp2
4189 code__2 dst = code1 `appOL` code2 `snocOL`
4192 returnNat (Any IntRep code__2)
4194 trivialFCode pk instr x y
4195 = getRegister x `thenNat` \ register1 ->
4196 getRegister y `thenNat` \ register2 ->
4197 getNewRegNCG (registerRep register1)
4199 getNewRegNCG (registerRep register2)
4201 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4203 -- promote x = FxTOy F DF x tmp
4205 pk1 = registerRep register1
4206 code1 = registerCode register1 tmp1
4207 src1 = registerName register1 tmp1
4209 pk2 = registerRep register2
4210 code2 = registerCode register2 tmp2
4211 src2 = registerName register2 tmp2
4215 code1 `appOL` code2 `snocOL`
4216 instr (primRepToSize pk) dst src1 src2
4217 else panic "###PPC MachCode.trivialFCode: type mismatch"
4219 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4221 trivialUCode instr x
4222 = getRegister x `thenNat` \ register ->
4223 getNewRegNCG IntRep `thenNat` \ tmp ->
4225 code = registerCode register tmp
4226 src = registerName register tmp
4227 code__2 dst = code `snocOL` instr dst src
4229 returnNat (Any IntRep code__2)
4230 trivialUFCode pk instr x = panic "###PPC MachCode.trivialUFCode"
4231 #endif {- powerpc_TARGET_ARCH -}
4233 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4236 %************************************************************************
4238 \subsubsection{Coercing to/from integer/floating-point...}
4240 %************************************************************************
4242 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4243 conversions. We have to store temporaries in memory to move
4244 between the integer and the floating point register sets.
4246 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4247 pretend, on sparc at least, that double and float regs are seperate
4248 kinds, so the value has to be computed into one kind before being
4249 explicitly "converted" to live in the other kind.
4252 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4253 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4255 coerceDbl2Flt :: StixExpr -> NatM Register
4256 coerceFlt2Dbl :: StixExpr -> NatM Register
4260 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4262 #if alpha_TARGET_ARCH
4265 = getRegister x `thenNat` \ register ->
4266 getNewRegNCG IntRep `thenNat` \ reg ->
4268 code = registerCode register reg
4269 src = registerName register reg
4271 code__2 dst = code . mkSeqInstrs [
4273 LD TF dst (spRel 0),
4276 returnNat (Any DoubleRep code__2)
4280 = getRegister x `thenNat` \ register ->
4281 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4283 code = registerCode register tmp
4284 src = registerName register tmp
4286 code__2 dst = code . mkSeqInstrs [
4288 ST TF tmp (spRel 0),
4291 returnNat (Any IntRep code__2)
4293 #endif {- alpha_TARGET_ARCH -}
4295 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4297 #if i386_TARGET_ARCH
4300 = getRegister x `thenNat` \ register ->
4301 getNewRegNCG IntRep `thenNat` \ reg ->
4303 code = registerCode register reg
4304 src = registerName register reg
4305 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4306 code__2 dst = code `snocOL` opc src dst
4308 returnNat (Any pk code__2)
4311 coerceFP2Int fprep x
4312 = getRegister x `thenNat` \ register ->
4313 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4315 code = registerCode register tmp
4316 src = registerName register tmp
4317 pk = registerRep register
4319 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4320 code__2 dst = code `snocOL` opc src dst
4322 returnNat (Any IntRep code__2)
4325 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4326 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4328 #endif {- i386_TARGET_ARCH -}
4330 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4332 #if sparc_TARGET_ARCH
4335 = getRegister x `thenNat` \ register ->
4336 getNewRegNCG IntRep `thenNat` \ reg ->
4338 code = registerCode register reg
4339 src = registerName register reg
4341 code__2 dst = code `appOL` toOL [
4342 ST W src (spRel (-2)),
4343 LD W (spRel (-2)) dst,
4344 FxTOy W (primRepToSize pk) dst dst]
4346 returnNat (Any pk code__2)
4349 coerceFP2Int fprep x
4350 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4351 getRegister x `thenNat` \ register ->
4352 getNewRegNCG fprep `thenNat` \ reg ->
4353 getNewRegNCG FloatRep `thenNat` \ tmp ->
4355 code = registerCode register reg
4356 src = registerName register reg
4357 code__2 dst = code `appOL` toOL [
4358 FxTOy (primRepToSize fprep) W src tmp,
4359 ST W tmp (spRel (-2)),
4360 LD W (spRel (-2)) dst]
4362 returnNat (Any IntRep code__2)
4366 = getRegister x `thenNat` \ register ->
4367 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4368 let code = registerCode register tmp
4369 src = registerName register tmp
4371 returnNat (Any FloatRep
4372 (\dst -> code `snocOL` FxTOy DF F src dst))
4376 = getRegister x `thenNat` \ register ->
4377 getNewRegNCG FloatRep `thenNat` \ tmp ->
4378 let code = registerCode register tmp
4379 src = registerName register tmp
4381 returnNat (Any DoubleRep
4382 (\dst -> code `snocOL` FxTOy F DF src dst))
4384 #endif {- sparc_TARGET_ARCH -}
4386 #if powerpc_TARGET_ARCH
4387 coerceInt2FP pk x = panic "###PPC MachCode.coerceInt2FP"
4388 coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int"
4389 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4390 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4391 #endif {- powerpc_TARGET_ARCH -}
4393 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -