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 -> trivialUCode (AND (RIImm (ImmInt 255))) x
1569 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1571 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1572 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1573 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1574 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1576 -- Conversions which are a nop on x86
1577 MO_NatS_to_32U -> conversionNop WordRep x
1578 MO_32U_to_NatS -> conversionNop IntRep x
1579 MO_32U_to_NatU -> conversionNop WordRep x
1581 MO_NatU_to_NatS -> conversionNop IntRep x
1582 MO_NatS_to_NatU -> conversionNop WordRep x
1583 MO_NatP_to_NatU -> conversionNop WordRep x
1584 MO_NatU_to_NatP -> conversionNop PtrRep x
1585 MO_NatS_to_NatP -> conversionNop PtrRep x
1586 MO_NatP_to_NatS -> conversionNop IntRep x
1588 MO_Dbl_to_Flt -> conversionNop FloatRep x
1589 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1591 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1592 MO_8U_to_NatU -> integerExtend False 24 x
1593 MO_8S_to_NatS -> integerExtend True 24 x
1594 MO_16U_to_NatU -> integerExtend False 16 x
1595 MO_16S_to_NatS -> integerExtend True 16 x
1596 MO_8U_to_32U -> integerExtend False 24 x
1598 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1601 integerExtend signed nBits x
1603 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1604 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1606 conversionNop new_rep expr
1607 = getRegister expr `thenNat` \ e_code ->
1608 returnNat (swizzleRegisterRep e_code new_rep)
1610 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1612 MO_32U_Gt -> condIntReg GTT x y
1613 MO_32U_Ge -> condIntReg GE x y
1614 MO_32U_Eq -> condIntReg EQQ x y
1615 MO_32U_Ne -> condIntReg NE x y
1616 MO_32U_Lt -> condIntReg LTT x y
1617 MO_32U_Le -> condIntReg LE x y
1619 MO_Nat_Eq -> condIntReg EQQ x y
1620 MO_Nat_Ne -> condIntReg NE x y
1622 MO_NatS_Gt -> condIntReg GTT x y
1623 MO_NatS_Ge -> condIntReg GE x y
1624 MO_NatS_Lt -> condIntReg LTT x y
1625 MO_NatS_Le -> condIntReg LE x y
1627 MO_NatU_Gt -> condIntReg GU x y
1628 MO_NatU_Ge -> condIntReg GEU x y
1629 MO_NatU_Lt -> condIntReg LU x y
1630 MO_NatU_Le -> condIntReg LEU x y
1632 MO_Flt_Gt -> condFltReg GTT x y
1633 MO_Flt_Ge -> condFltReg GE x y
1634 MO_Flt_Eq -> condFltReg EQQ x y
1635 MO_Flt_Ne -> condFltReg NE x y
1636 MO_Flt_Lt -> condFltReg LTT x y
1637 MO_Flt_Le -> condFltReg LE x y
1639 MO_Dbl_Gt -> condFltReg GTT x y
1640 MO_Dbl_Ge -> condFltReg GE x y
1641 MO_Dbl_Eq -> condFltReg EQQ x y
1642 MO_Dbl_Ne -> condFltReg NE x y
1643 MO_Dbl_Lt -> condFltReg LTT x y
1644 MO_Dbl_Le -> condFltReg LE x y
1646 MO_Nat_Add -> trivialCode ADD x y
1647 MO_Nat_Sub -> trivialCode SUBF y x
1649 MO_NatS_Mul -> trivialCode MULLW x y
1650 MO_NatU_Mul -> trivialCode MULLW x y
1652 MO_NatS_Quot -> trivialCode2 DIVW x y
1653 MO_NatU_Quot -> trivialCode2 DIVWU x y
1655 MO_Nat_And -> trivialCode AND x y
1656 MO_Nat_Or -> trivialCode OR x y
1657 MO_Nat_Xor -> trivialCode XOR x y
1659 MO_Nat_Shl -> trivialCode SLW x y
1660 MO_Nat_Shr -> trivialCode SRW x y
1661 MO_Nat_Sar -> trivialCode SRAW x y
1663 {- MO_NatS_Mul -> trivialCode (SMUL False) x y
1664 MO_NatU_Mul -> trivialCode (UMUL False) x y
1665 MO_NatS_MulMayOflo -> imulMayOflo x y
1667 -- ToDo: teach about V8+ SPARC div instructions
1668 MO_NatS_Quot -> idiv FSLIT(".div") x y
1669 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1670 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1671 MO_NatU_Rem -> idiv FSLIT(".urem") x y -}
1673 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1674 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1675 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1676 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1678 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1679 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1680 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1681 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1683 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1684 [promote x, promote y])
1685 where promote x = StMachOp MO_Flt_to_Dbl [x]
1686 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1689 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1691 getRegister (StInd pk mem)
1692 = getAmode mem `thenNat` \ amode ->
1694 code = amodeCode amode
1695 src = amodeAddr amode
1696 size = primRepToSize pk
1697 code__2 dst = code `snocOL` LD size dst src
1699 returnNat (Any pk code__2)
1701 getRegister (StInt i)
1704 src = ImmInt (fromInteger i)
1705 code dst = unitOL (LI dst src)
1707 returnNat (Any IntRep code)
1709 getRegister (StFloat d)
1710 = getNatLabelNCG `thenNat` \ lbl ->
1711 getNewRegNCG PtrRep `thenNat` \ tmp ->
1712 let code dst = toOL [
1713 SEGMENT RoDataSegment,
1715 DATA F [ImmFloat d],
1716 SEGMENT TextSegment,
1717 LIS tmp (HA (ImmCLbl lbl)),
1718 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1720 returnNat (Any FloatRep code)
1722 getRegister (StDouble d)
1723 = getNatLabelNCG `thenNat` \ lbl ->
1724 getNewRegNCG PtrRep `thenNat` \ tmp ->
1725 let code dst = toOL [
1726 SEGMENT RoDataSegment,
1728 DATA DF [ImmDouble d],
1729 SEGMENT TextSegment,
1730 LIS tmp (HA (ImmCLbl lbl)),
1731 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1733 returnNat (Any DoubleRep code)
1739 LIS dst (HI imm__2),
1740 OR dst dst (RIImm (LO imm__2))]
1742 returnNat (Any PtrRep code)
1744 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1747 imm__2 = case imm of Just x -> x
1748 #endif {- powerpc_TARGET_ARCH -}
1750 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1752 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1756 %************************************************************************
1758 \subsection{The @Amode@ type}
1760 %************************************************************************
1762 @Amode@s: Memory addressing modes passed up the tree.
1764 data Amode = Amode MachRegsAddr InstrBlock
1766 amodeAddr (Amode addr _) = addr
1767 amodeCode (Amode _ code) = code
1770 Now, given a tree (the argument to an StInd) that references memory,
1771 produce a suitable addressing mode.
1773 A Rule of the Game (tm) for Amodes: use of the addr bit must
1774 immediately follow use of the code part, since the code part puts
1775 values in registers which the addr then refers to. So you can't put
1776 anything in between, lest it overwrite some of those registers. If
1777 you need to do some other computation between the code part and use of
1778 the addr bit, first store the effective address from the amode in a
1779 temporary, then do the other computation, and then use the temporary:
1783 ... other computation ...
1787 getAmode :: StixExpr -> NatM Amode
1789 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1791 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1793 #if alpha_TARGET_ARCH
1795 getAmode (StPrim IntSubOp [x, StInt i])
1796 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1797 getRegister x `thenNat` \ register ->
1799 code = registerCode register tmp
1800 reg = registerName register tmp
1801 off = ImmInt (-(fromInteger i))
1803 returnNat (Amode (AddrRegImm reg off) code)
1805 getAmode (StPrim IntAddOp [x, StInt i])
1806 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1807 getRegister x `thenNat` \ register ->
1809 code = registerCode register tmp
1810 reg = registerName register tmp
1811 off = ImmInt (fromInteger i)
1813 returnNat (Amode (AddrRegImm reg off) code)
1817 = returnNat (Amode (AddrImm imm__2) id)
1820 imm__2 = case imm of Just x -> x
1823 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1824 getRegister other `thenNat` \ register ->
1826 code = registerCode register tmp
1827 reg = registerName register tmp
1829 returnNat (Amode (AddrReg reg) code)
1831 #endif {- alpha_TARGET_ARCH -}
1833 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1835 #if i386_TARGET_ARCH
1837 -- This is all just ridiculous, since it carefully undoes
1838 -- what mangleIndexTree has just done.
1839 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1840 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1841 getRegister x `thenNat` \ register ->
1843 code = registerCode register tmp
1844 reg = registerName register tmp
1845 off = ImmInt (-(fromInteger i))
1847 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1849 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1851 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1854 imm__2 = case imm of Just x -> x
1856 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1857 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1858 getRegister x `thenNat` \ register ->
1860 code = registerCode register tmp
1861 reg = registerName register tmp
1862 off = ImmInt (fromInteger i)
1864 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1866 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1867 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1868 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1869 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1870 getRegister x `thenNat` \ register1 ->
1871 getRegister y `thenNat` \ register2 ->
1873 code1 = registerCode register1 tmp1
1874 reg1 = registerName register1 tmp1
1875 code2 = registerCode register2 tmp2
1876 reg2 = registerName register2 tmp2
1877 code__2 = code1 `appOL` code2
1878 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1880 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1885 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1888 imm__2 = case imm of Just x -> x
1891 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1892 getRegister other `thenNat` \ register ->
1894 code = registerCode register tmp
1895 reg = registerName register tmp
1897 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1899 #endif {- i386_TARGET_ARCH -}
1901 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1903 #if sparc_TARGET_ARCH
1905 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1907 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1908 getRegister x `thenNat` \ register ->
1910 code = registerCode register tmp
1911 reg = registerName register tmp
1912 off = ImmInt (-(fromInteger i))
1914 returnNat (Amode (AddrRegImm reg off) code)
1917 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1919 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1920 getRegister x `thenNat` \ register ->
1922 code = registerCode register tmp
1923 reg = registerName register tmp
1924 off = ImmInt (fromInteger i)
1926 returnNat (Amode (AddrRegImm reg off) code)
1928 getAmode (StMachOp MO_Nat_Add [x, y])
1929 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1930 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1931 getRegister x `thenNat` \ register1 ->
1932 getRegister y `thenNat` \ register2 ->
1934 code1 = registerCode register1 tmp1
1935 reg1 = registerName register1 tmp1
1936 code2 = registerCode register2 tmp2
1937 reg2 = registerName register2 tmp2
1938 code__2 = code1 `appOL` code2
1940 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1944 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1946 code = unitOL (SETHI (HI imm__2) tmp)
1948 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1951 imm__2 = case imm of Just x -> x
1954 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1955 getRegister other `thenNat` \ register ->
1957 code = registerCode register tmp
1958 reg = registerName register tmp
1961 returnNat (Amode (AddrRegImm reg off) code)
1963 #endif {- sparc_TARGET_ARCH -}
1965 #ifdef powerpc_TARGET_ARCH
1966 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1968 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1969 getRegister x `thenNat` \ register ->
1971 code = registerCode register tmp
1972 reg = registerName register tmp
1973 off = ImmInt (-(fromInteger i))
1975 returnNat (Amode (AddrRegImm reg off) code)
1978 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1980 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1981 getRegister x `thenNat` \ register ->
1983 code = registerCode register tmp
1984 reg = registerName register tmp
1985 off = ImmInt (fromInteger i)
1987 returnNat (Amode (AddrRegImm reg off) code)
1991 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1993 code = unitOL (LIS tmp (HA imm__2))
1995 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1998 imm__2 = case imm of Just x -> x
2001 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2002 getRegister other `thenNat` \ register ->
2004 code = registerCode register tmp
2005 reg = registerName register tmp
2008 returnNat (Amode (AddrRegImm reg off) code)
2009 #endif {- powerpc_TARGET_ARCH -}
2011 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2014 %************************************************************************
2016 \subsection{The @CondCode@ type}
2018 %************************************************************************
2020 Condition codes passed up the tree.
2022 data CondCode = CondCode Bool Cond InstrBlock
2024 condName (CondCode _ cond _) = cond
2025 condFloat (CondCode is_float _ _) = is_float
2026 condCode (CondCode _ _ code) = code
2029 Set up a condition code for a conditional branch.
2032 getCondCode :: StixExpr -> NatM CondCode
2034 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2036 #if alpha_TARGET_ARCH
2037 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2038 #endif {- alpha_TARGET_ARCH -}
2040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2042 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2043 -- yes, they really do seem to want exactly the same!
2045 getCondCode (StMachOp mop [x, y])
2047 MO_32U_Gt -> condIntCode GTT x y
2048 MO_32U_Ge -> condIntCode GE x y
2049 MO_32U_Eq -> condIntCode EQQ x y
2050 MO_32U_Ne -> condIntCode NE x y
2051 MO_32U_Lt -> condIntCode LTT x y
2052 MO_32U_Le -> condIntCode LE x y
2054 MO_Nat_Eq -> condIntCode EQQ x y
2055 MO_Nat_Ne -> condIntCode NE x y
2057 MO_NatS_Gt -> condIntCode GTT x y
2058 MO_NatS_Ge -> condIntCode GE x y
2059 MO_NatS_Lt -> condIntCode LTT x y
2060 MO_NatS_Le -> condIntCode LE x y
2062 MO_NatU_Gt -> condIntCode GU x y
2063 MO_NatU_Ge -> condIntCode GEU x y
2064 MO_NatU_Lt -> condIntCode LU x y
2065 MO_NatU_Le -> condIntCode LEU x y
2067 MO_Flt_Gt -> condFltCode GTT x y
2068 MO_Flt_Ge -> condFltCode GE x y
2069 MO_Flt_Eq -> condFltCode EQQ x y
2070 MO_Flt_Ne -> condFltCode NE x y
2071 MO_Flt_Lt -> condFltCode LTT x y
2072 MO_Flt_Le -> condFltCode LE x y
2074 MO_Dbl_Gt -> condFltCode GTT x y
2075 MO_Dbl_Ge -> condFltCode GE x y
2076 MO_Dbl_Eq -> condFltCode EQQ x y
2077 MO_Dbl_Ne -> condFltCode NE x y
2078 MO_Dbl_Lt -> condFltCode LTT x y
2079 MO_Dbl_Le -> condFltCode LE x y
2081 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2083 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2085 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH -}
2088 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2093 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2094 passed back up the tree.
2097 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2099 #if alpha_TARGET_ARCH
2100 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2101 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2102 #endif {- alpha_TARGET_ARCH -}
2104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2105 #if i386_TARGET_ARCH
2107 -- memory vs immediate
2108 condIntCode cond (StInd pk x) y
2109 | Just i <- maybeImm y
2110 = getAmode x `thenNat` \ amode ->
2112 code1 = amodeCode amode
2113 x__2 = amodeAddr amode
2114 sz = primRepToSize pk
2115 code__2 = code1 `snocOL`
2116 CMP sz (OpImm i) (OpAddr x__2)
2118 returnNat (CondCode False cond code__2)
2121 condIntCode cond x (StInt 0)
2122 = getRegister x `thenNat` \ register1 ->
2123 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2125 code1 = registerCode register1 tmp1
2126 src1 = registerName register1 tmp1
2127 code__2 = code1 `snocOL`
2128 TEST L (OpReg src1) (OpReg src1)
2130 returnNat (CondCode False cond code__2)
2132 -- anything vs immediate
2133 condIntCode cond x y
2134 | Just i <- maybeImm y
2135 = getRegister x `thenNat` \ register1 ->
2136 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2138 code1 = registerCode register1 tmp1
2139 src1 = registerName register1 tmp1
2140 code__2 = code1 `snocOL`
2141 CMP L (OpImm i) (OpReg src1)
2143 returnNat (CondCode False cond code__2)
2145 -- memory vs anything
2146 condIntCode cond (StInd pk x) y
2147 = getAmode x `thenNat` \ amode_x ->
2148 getRegister y `thenNat` \ reg_y ->
2149 getNewRegNCG IntRep `thenNat` \ tmp ->
2151 c_x = amodeCode amode_x
2152 am_x = amodeAddr amode_x
2153 c_y = registerCode reg_y tmp
2154 r_y = registerName reg_y tmp
2155 sz = primRepToSize pk
2157 -- optimisation: if there's no code for x, just an amode,
2158 -- use whatever reg y winds up in. Assumes that c_y doesn't
2159 -- clobber any regs in the amode am_x, which I'm not sure is
2160 -- justified. The otherwise clause makes the same assumption.
2161 code__2 | isNilOL c_x
2163 CMP sz (OpReg r_y) (OpAddr am_x)
2167 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2169 CMP sz (OpReg tmp) (OpAddr am_x)
2171 returnNat (CondCode False cond code__2)
2173 -- anything vs memory
2175 condIntCode cond y (StInd pk x)
2176 = getAmode x `thenNat` \ amode_x ->
2177 getRegister y `thenNat` \ reg_y ->
2178 getNewRegNCG IntRep `thenNat` \ tmp ->
2180 c_x = amodeCode amode_x
2181 am_x = amodeAddr amode_x
2182 c_y = registerCode reg_y tmp
2183 r_y = registerName reg_y tmp
2184 sz = primRepToSize pk
2185 -- same optimisation and nagging doubts as previous clause
2186 code__2 | isNilOL c_x
2188 CMP sz (OpAddr am_x) (OpReg r_y)
2192 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2194 CMP sz (OpAddr am_x) (OpReg tmp)
2196 returnNat (CondCode False cond code__2)
2198 -- anything vs anything
2199 condIntCode cond x y
2200 = getRegister x `thenNat` \ register1 ->
2201 getRegister y `thenNat` \ register2 ->
2202 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2203 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2205 code1 = registerCode register1 tmp1
2206 src1 = registerName register1 tmp1
2207 code2 = registerCode register2 tmp2
2208 src2 = registerName register2 tmp2
2209 code__2 = code1 `snocOL`
2210 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2212 CMP L (OpReg src2) (OpReg tmp1)
2214 returnNat (CondCode False cond code__2)
2217 condFltCode cond x y
2218 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2219 getRegister x `thenNat` \ register1 ->
2220 getRegister y `thenNat` \ register2 ->
2221 getNewRegNCG (registerRep register1)
2223 getNewRegNCG (registerRep register2)
2225 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2227 code1 = registerCode register1 tmp1
2228 src1 = registerName register1 tmp1
2230 code2 = registerCode register2 tmp2
2231 src2 = registerName register2 tmp2
2233 code__2 | isAny register1
2234 = code1 `appOL` -- result in tmp1
2240 GMOV src1 tmp1 `appOL`
2244 -- The GCMP insn does the test and sets the zero flag if comparable
2245 -- and true. Hence we always supply EQQ as the condition to test.
2246 returnNat (CondCode True EQQ code__2)
2248 #endif {- i386_TARGET_ARCH -}
2250 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2252 #if sparc_TARGET_ARCH
2254 condIntCode cond x (StInt y)
2256 = getRegister x `thenNat` \ register ->
2257 getNewRegNCG IntRep `thenNat` \ tmp ->
2259 code = registerCode register tmp
2260 src1 = registerName register tmp
2261 src2 = ImmInt (fromInteger y)
2262 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2264 returnNat (CondCode False cond code__2)
2266 condIntCode cond x y
2267 = getRegister x `thenNat` \ register1 ->
2268 getRegister y `thenNat` \ register2 ->
2269 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2270 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2272 code1 = registerCode register1 tmp1
2273 src1 = registerName register1 tmp1
2274 code2 = registerCode register2 tmp2
2275 src2 = registerName register2 tmp2
2276 code__2 = code1 `appOL` code2 `snocOL`
2277 SUB False True src1 (RIReg src2) g0
2279 returnNat (CondCode False cond code__2)
2282 condFltCode cond x y
2283 = getRegister x `thenNat` \ register1 ->
2284 getRegister y `thenNat` \ register2 ->
2285 getNewRegNCG (registerRep register1)
2287 getNewRegNCG (registerRep register2)
2289 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2291 promote x = FxTOy F DF x tmp
2293 pk1 = registerRep register1
2294 code1 = registerCode register1 tmp1
2295 src1 = registerName register1 tmp1
2297 pk2 = registerRep register2
2298 code2 = registerCode register2 tmp2
2299 src2 = registerName register2 tmp2
2303 code1 `appOL` code2 `snocOL`
2304 FCMP True (primRepToSize pk1) src1 src2
2305 else if pk1 == FloatRep then
2306 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2307 FCMP True DF tmp src2
2309 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2310 FCMP True DF src1 tmp
2312 returnNat (CondCode True cond code__2)
2314 #endif {- sparc_TARGET_ARCH -}
2316 #if powerpc_TARGET_ARCH
2318 condIntCode cond x (StInt y)
2320 = getRegister x `thenNat` \ register ->
2321 getNewRegNCG IntRep `thenNat` \ tmp ->
2323 code = registerCode register tmp
2324 src1 = registerName register tmp
2325 src2 = ImmInt (fromInteger y)
2326 code__2 = code `snocOL`
2327 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2329 returnNat (CondCode False cond code__2)
2331 condIntCode cond x y
2332 = getRegister x `thenNat` \ register1 ->
2333 getRegister y `thenNat` \ register2 ->
2334 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2335 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2337 code1 = registerCode register1 tmp1
2338 src1 = registerName register1 tmp1
2339 code2 = registerCode register2 tmp2
2340 src2 = registerName register2 tmp2
2341 code__2 = code1 `appOL` code2 `snocOL`
2342 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2344 returnNat (CondCode False cond code__2)
2346 condFltCode cond x y
2347 = getRegister x `thenNat` \ register1 ->
2348 getRegister y `thenNat` \ register2 ->
2349 getNewRegNCG (registerRep register1)
2351 getNewRegNCG (registerRep register2)
2354 code1 = registerCode register1 tmp1
2355 src1 = registerName register1 tmp1
2356 code2 = registerCode register2 tmp2
2357 src2 = registerName register2 tmp2
2358 code__2 = code1 `appOL` code2 `snocOL`
2361 returnNat (CondCode False cond code__2)
2363 #endif {- powerpc_TARGET_ARCH -}
2366 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2369 %************************************************************************
2371 \subsection{Generating assignments}
2373 %************************************************************************
2375 Assignments are really at the heart of the whole code generation
2376 business. Almost all top-level nodes of any real importance are
2377 assignments, which correspond to loads, stores, or register transfers.
2378 If we're really lucky, some of the register transfers will go away,
2379 because we can use the destination register to complete the code
2380 generation for the right hand side. This only fails when the right
2381 hand side is forced into a fixed register (e.g. the result of a call).
2384 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2385 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2387 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2388 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2390 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2392 #if alpha_TARGET_ARCH
2394 assignIntCode pk (StInd _ dst) src
2395 = getNewRegNCG IntRep `thenNat` \ tmp ->
2396 getAmode dst `thenNat` \ amode ->
2397 getRegister src `thenNat` \ register ->
2399 code1 = amodeCode amode []
2400 dst__2 = amodeAddr amode
2401 code2 = registerCode register tmp []
2402 src__2 = registerName register tmp
2403 sz = primRepToSize pk
2404 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2408 assignIntCode pk dst src
2409 = getRegister dst `thenNat` \ register1 ->
2410 getRegister src `thenNat` \ register2 ->
2412 dst__2 = registerName register1 zeroh
2413 code = registerCode register2 dst__2
2414 src__2 = registerName register2 dst__2
2415 code__2 = if isFixed register2
2416 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2421 #endif {- alpha_TARGET_ARCH -}
2423 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2425 #if i386_TARGET_ARCH
2427 -- non-FP assignment to memory
2428 assignMem_IntCode pk addr src
2429 = getAmode addr `thenNat` \ amode ->
2430 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2431 getNewRegNCG PtrRep `thenNat` \ tmp ->
2433 -- In general, if the address computation for dst may require
2434 -- some insns preceding the addressing mode itself. So there's
2435 -- no guarantee that the code for dst and the code for src won't
2436 -- write the same register. This means either the address or
2437 -- the value needs to be copied into a temporary. We detect the
2438 -- common case where the amode has no code, and elide the copy.
2439 codea = amodeCode amode
2440 dst__a = amodeAddr amode
2442 code | isNilOL codea
2444 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2447 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2449 MOV (primRepToSize pk) opsrc
2450 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2456 -> NatM (InstrBlock,Operand) -- code, operator
2459 | Just x <- maybeImm op
2460 = returnNat (nilOL, OpImm x)
2463 = getRegister op `thenNat` \ register ->
2464 getNewRegNCG (registerRep register)
2466 let code = registerCode register tmp
2467 reg = registerName register tmp
2469 returnNat (code, OpReg reg)
2471 -- Assign; dst is a reg, rhs is mem
2472 assignReg_IntCode pk reg (StInd pks src)
2473 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2474 getAmode src `thenNat` \ amode ->
2475 getRegisterReg reg `thenNat` \ reg_dst ->
2477 c_addr = amodeCode amode
2478 am_addr = amodeAddr amode
2479 r_dst = registerName reg_dst tmp
2480 szs = primRepToSize pks
2489 code = c_addr `snocOL`
2490 opc (OpAddr am_addr) (OpReg r_dst)
2494 -- dst is a reg, but src could be anything
2495 assignReg_IntCode pk reg src
2496 = getRegisterReg reg `thenNat` \ registerd ->
2497 getRegister src `thenNat` \ registers ->
2498 getNewRegNCG IntRep `thenNat` \ tmp ->
2500 r_dst = registerName registerd tmp
2501 r_src = registerName registers r_dst
2502 c_src = registerCode registers r_dst
2504 code = c_src `snocOL`
2505 MOV L (OpReg r_src) (OpReg r_dst)
2509 #endif {- i386_TARGET_ARCH -}
2511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2513 #if sparc_TARGET_ARCH
2515 assignMem_IntCode pk addr src
2516 = getNewRegNCG IntRep `thenNat` \ tmp ->
2517 getAmode addr `thenNat` \ amode ->
2518 getRegister src `thenNat` \ register ->
2520 code1 = amodeCode amode
2521 dst__2 = amodeAddr amode
2522 code2 = registerCode register tmp
2523 src__2 = registerName register tmp
2524 sz = primRepToSize pk
2525 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2529 assignReg_IntCode pk reg src
2530 = getRegister src `thenNat` \ register2 ->
2531 getRegisterReg reg `thenNat` \ register1 ->
2532 getNewRegNCG IntRep `thenNat` \ tmp ->
2534 dst__2 = registerName register1 tmp
2535 code = registerCode register2 dst__2
2536 src__2 = registerName register2 dst__2
2537 code__2 = if isFixed register2
2538 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2543 #endif {- sparc_TARGET_ARCH -}
2545 #if powerpc_TARGET_ARCH
2547 assignMem_IntCode pk addr src
2548 = getNewRegNCG IntRep `thenNat` \ tmp ->
2549 getAmode addr `thenNat` \ amode ->
2550 getRegister src `thenNat` \ register ->
2552 code1 = amodeCode amode
2553 dst__2 = amodeAddr amode
2554 code2 = registerCode register tmp
2555 src__2 = registerName register tmp
2556 sz = primRepToSize pk
2557 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2561 assignReg_IntCode pk reg src
2562 = getRegister src `thenNat` \ register2 ->
2563 getRegisterReg reg `thenNat` \ register1 ->
2565 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2566 code = registerCode register2 dst__2
2567 src__2 = registerName register2 dst__2
2568 code__2 = if isFixed register2
2569 then code `snocOL` MR dst__2 src__2
2574 #endif {- powerpc_TARGET_ARCH -}
2576 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2579 % --------------------------------
2580 Floating-point assignments:
2581 % --------------------------------
2584 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2585 #if alpha_TARGET_ARCH
2587 assignFltCode pk (StInd _ dst) src
2588 = getNewRegNCG pk `thenNat` \ tmp ->
2589 getAmode dst `thenNat` \ amode ->
2590 getRegister src `thenNat` \ register ->
2592 code1 = amodeCode amode []
2593 dst__2 = amodeAddr amode
2594 code2 = registerCode register tmp []
2595 src__2 = registerName register tmp
2596 sz = primRepToSize pk
2597 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2601 assignFltCode pk dst src
2602 = getRegister dst `thenNat` \ register1 ->
2603 getRegister src `thenNat` \ register2 ->
2605 dst__2 = registerName register1 zeroh
2606 code = registerCode register2 dst__2
2607 src__2 = registerName register2 dst__2
2608 code__2 = if isFixed register2
2609 then code . mkSeqInstr (FMOV src__2 dst__2)
2614 #endif {- alpha_TARGET_ARCH -}
2616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2618 #if i386_TARGET_ARCH
2620 -- Floating point assignment to memory
2621 assignMem_FltCode pk addr src
2622 = getRegister src `thenNat` \ reg_src ->
2623 getRegister addr `thenNat` \ reg_addr ->
2624 getNewRegNCG pk `thenNat` \ tmp_src ->
2625 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2626 let r_src = registerName reg_src tmp_src
2627 c_src = registerCode reg_src tmp_src
2628 r_addr = registerName reg_addr tmp_addr
2629 c_addr = registerCode reg_addr tmp_addr
2630 sz = primRepToSize pk
2632 code = c_src `appOL`
2633 -- no need to preserve r_src across the addr computation,
2634 -- since r_src must be a float reg
2635 -- whilst r_addr is an int reg
2638 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2642 -- Floating point assignment to a register/temporary
2643 assignReg_FltCode pk reg src
2644 = getRegisterReg reg `thenNat` \ reg_dst ->
2645 getRegister src `thenNat` \ reg_src ->
2646 getNewRegNCG pk `thenNat` \ tmp ->
2648 r_dst = registerName reg_dst tmp
2649 r_src = registerName reg_src r_dst
2650 c_src = registerCode reg_src r_dst
2652 code = if isFixed reg_src
2653 then c_src `snocOL` GMOV r_src r_dst
2659 #endif {- i386_TARGET_ARCH -}
2661 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2663 #if sparc_TARGET_ARCH
2665 -- Floating point assignment to memory
2666 assignMem_FltCode pk addr src
2667 = getNewRegNCG pk `thenNat` \ tmp1 ->
2668 getAmode addr `thenNat` \ amode ->
2669 getRegister src `thenNat` \ register ->
2671 sz = primRepToSize pk
2672 dst__2 = amodeAddr amode
2674 code1 = amodeCode amode
2675 code2 = registerCode register tmp1
2677 src__2 = registerName register tmp1
2678 pk__2 = registerRep register
2679 sz__2 = primRepToSize pk__2
2681 code__2 = code1 `appOL` code2 `appOL`
2683 then unitOL (ST sz src__2 dst__2)
2684 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2688 -- Floating point assignment to a register/temporary
2689 -- Why is this so bizarrely ugly?
2690 assignReg_FltCode pk reg src
2691 = getRegisterReg reg `thenNat` \ register1 ->
2692 getRegister src `thenNat` \ register2 ->
2694 pk__2 = registerRep register2
2695 sz__2 = primRepToSize pk__2
2697 getNewRegNCG pk__2 `thenNat` \ tmp ->
2699 sz = primRepToSize pk
2700 dst__2 = registerName register1 g0 -- must be Fixed
2701 reg__2 = if pk /= pk__2 then tmp else dst__2
2702 code = registerCode register2 reg__2
2703 src__2 = registerName register2 reg__2
2706 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2707 else if isFixed register2 then
2708 code `snocOL` FMOV sz src__2 dst__2
2714 #endif {- sparc_TARGET_ARCH -}
2716 #if powerpc_TARGET_ARCH
2718 -- Floating point assignment to memory
2719 assignMem_FltCode pk addr src
2720 = getNewRegNCG pk `thenNat` \ tmp1 ->
2721 getAmode addr `thenNat` \ amode ->
2722 getRegister src `thenNat` \ register ->
2724 sz = primRepToSize pk
2725 dst__2 = amodeAddr amode
2727 code1 = amodeCode amode
2728 code2 = registerCode register tmp1
2730 src__2 = registerName register tmp1
2731 pk__2 = registerRep register
2732 sz__2 = primRepToSize pk__2
2734 code__2 = if pk__2 == DoubleRep || pk == pk__2
2735 then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2736 else panic "###PPC MachCode.assignMem_FltCode: FloatRep"
2737 {- code__2 = code1 `appOL` code2 `appOL`
2739 then unitOL (ST sz src__2 dst__2)
2740 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] -}
2744 -- Floating point assignment to a register/temporary
2745 assignReg_FltCode pk reg src
2746 = getRegisterReg reg `thenNat` \ reg_dst ->
2747 getRegister src `thenNat` \ reg_src ->
2748 getNewRegNCG pk `thenNat` \ tmp ->
2750 r_dst = registerName reg_dst tmp
2751 r_src = registerName reg_src r_dst
2752 c_src = registerCode reg_src r_dst
2754 code = if isFixed reg_src
2755 then c_src `snocOL` MR r_dst r_src
2759 #endif {- powerpc_TARGET_ARCH -}
2761 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2764 %************************************************************************
2766 \subsection{Generating an unconditional branch}
2768 %************************************************************************
2770 We accept two types of targets: an immediate CLabel or a tree that
2771 gets evaluated into a register. Any CLabels which are AsmTemporaries
2772 are assumed to be in the local block of code, close enough for a
2773 branch instruction. Other CLabels are assumed to be far away.
2775 (If applicable) Do not fill the delay slots here; you will confuse the
2779 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2783 #if alpha_TARGET_ARCH
2785 genJump (StCLbl lbl)
2786 | isAsmTemp lbl = returnInstr (BR target)
2787 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2789 target = ImmCLbl lbl
2792 = getRegister tree `thenNat` \ register ->
2793 getNewRegNCG PtrRep `thenNat` \ tmp ->
2795 dst = registerName register pv
2796 code = registerCode register pv
2797 target = registerName register pv
2799 if isFixed register then
2800 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2802 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2804 #endif {- alpha_TARGET_ARCH -}
2806 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2808 #if i386_TARGET_ARCH
2810 genJump dsts (StInd pk mem)
2811 = getAmode mem `thenNat` \ amode ->
2813 code = amodeCode amode
2814 target = amodeAddr amode
2816 returnNat (code `snocOL` JMP dsts (OpAddr target))
2820 = returnNat (unitOL (JMP dsts (OpImm target)))
2823 = getRegister tree `thenNat` \ register ->
2824 getNewRegNCG PtrRep `thenNat` \ tmp ->
2826 code = registerCode register tmp
2827 target = registerName register tmp
2829 returnNat (code `snocOL` JMP dsts (OpReg target))
2832 target = case imm of Just x -> x
2834 #endif {- i386_TARGET_ARCH -}
2836 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2838 #if sparc_TARGET_ARCH
2840 genJump dsts (StCLbl lbl)
2841 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2842 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2843 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2845 target = ImmCLbl lbl
2848 = getRegister tree `thenNat` \ register ->
2849 getNewRegNCG PtrRep `thenNat` \ tmp ->
2851 code = registerCode register tmp
2852 target = registerName register tmp
2854 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2856 #endif {- sparc_TARGET_ARCH -}
2858 #if powerpc_TARGET_ARCH
2859 genJump dsts (StCLbl lbl)
2860 = returnNat (toOL [BCC ALWAYS lbl])
2863 = getRegister tree `thenNat` \ register ->
2864 getNewRegNCG PtrRep `thenNat` \ tmp ->
2866 code = registerCode register tmp
2867 target = registerName register tmp
2869 returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
2870 #endif {- sparc_TARGET_ARCH -}
2872 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2877 %************************************************************************
2879 \subsection{Conditional jumps}
2881 %************************************************************************
2883 Conditional jumps are always to local labels, so we can use branch
2884 instructions. We peek at the arguments to decide what kind of
2887 ALPHA: For comparisons with 0, we're laughing, because we can just do
2888 the desired conditional branch.
2890 I386: First, we have to ensure that the condition
2891 codes are set according to the supplied comparison operation.
2893 SPARC: First, we have to ensure that the condition codes are set
2894 according to the supplied comparison operation. We generate slightly
2895 different code for floating point comparisons, because a floating
2896 point operation cannot directly precede a @BF@. We assume the worst
2897 and fill that slot with a @NOP@.
2899 SPARC: Do not fill the delay slots here; you will confuse the register
2904 :: CLabel -- the branch target
2905 -> StixExpr -- the condition on which to branch
2908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2910 #if alpha_TARGET_ARCH
2912 genCondJump lbl (StPrim op [x, StInt 0])
2913 = getRegister x `thenNat` \ register ->
2914 getNewRegNCG (registerRep register)
2917 code = registerCode register tmp
2918 value = registerName register tmp
2919 pk = registerRep register
2920 target = ImmCLbl lbl
2922 returnSeq code [BI (cmpOp op) value target]
2924 cmpOp CharGtOp = GTT
2926 cmpOp CharEqOp = EQQ
2928 cmpOp CharLtOp = LTT
2937 cmpOp WordGeOp = ALWAYS
2938 cmpOp WordEqOp = EQQ
2940 cmpOp WordLtOp = NEVER
2941 cmpOp WordLeOp = EQQ
2943 cmpOp AddrGeOp = ALWAYS
2944 cmpOp AddrEqOp = EQQ
2946 cmpOp AddrLtOp = NEVER
2947 cmpOp AddrLeOp = EQQ
2949 genCondJump lbl (StPrim op [x, StDouble 0.0])
2950 = getRegister x `thenNat` \ register ->
2951 getNewRegNCG (registerRep register)
2954 code = registerCode register tmp
2955 value = registerName register tmp
2956 pk = registerRep register
2957 target = ImmCLbl lbl
2959 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2961 cmpOp FloatGtOp = GTT
2962 cmpOp FloatGeOp = GE
2963 cmpOp FloatEqOp = EQQ
2964 cmpOp FloatNeOp = NE
2965 cmpOp FloatLtOp = LTT
2966 cmpOp FloatLeOp = LE
2967 cmpOp DoubleGtOp = GTT
2968 cmpOp DoubleGeOp = GE
2969 cmpOp DoubleEqOp = EQQ
2970 cmpOp DoubleNeOp = NE
2971 cmpOp DoubleLtOp = LTT
2972 cmpOp DoubleLeOp = LE
2974 genCondJump lbl (StPrim op [x, y])
2976 = trivialFCode pr instr x y `thenNat` \ register ->
2977 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2979 code = registerCode register tmp
2980 result = registerName register tmp
2981 target = ImmCLbl lbl
2983 returnNat (code . mkSeqInstr (BF cond result target))
2985 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2987 fltCmpOp op = case op of
3001 (instr, cond) = case op of
3002 FloatGtOp -> (FCMP TF LE, EQQ)
3003 FloatGeOp -> (FCMP TF LTT, EQQ)
3004 FloatEqOp -> (FCMP TF EQQ, NE)
3005 FloatNeOp -> (FCMP TF EQQ, EQQ)
3006 FloatLtOp -> (FCMP TF LTT, NE)
3007 FloatLeOp -> (FCMP TF LE, NE)
3008 DoubleGtOp -> (FCMP TF LE, EQQ)
3009 DoubleGeOp -> (FCMP TF LTT, EQQ)
3010 DoubleEqOp -> (FCMP TF EQQ, NE)
3011 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3012 DoubleLtOp -> (FCMP TF LTT, NE)
3013 DoubleLeOp -> (FCMP TF LE, NE)
3015 genCondJump lbl (StPrim op [x, y])
3016 = trivialCode instr x y `thenNat` \ register ->
3017 getNewRegNCG IntRep `thenNat` \ tmp ->
3019 code = registerCode register tmp
3020 result = registerName register tmp
3021 target = ImmCLbl lbl
3023 returnNat (code . mkSeqInstr (BI cond result target))
3025 (instr, cond) = case op of
3026 CharGtOp -> (CMP LE, EQQ)
3027 CharGeOp -> (CMP LTT, EQQ)
3028 CharEqOp -> (CMP EQQ, NE)
3029 CharNeOp -> (CMP EQQ, EQQ)
3030 CharLtOp -> (CMP LTT, NE)
3031 CharLeOp -> (CMP LE, NE)
3032 IntGtOp -> (CMP LE, EQQ)
3033 IntGeOp -> (CMP LTT, EQQ)
3034 IntEqOp -> (CMP EQQ, NE)
3035 IntNeOp -> (CMP EQQ, EQQ)
3036 IntLtOp -> (CMP LTT, NE)
3037 IntLeOp -> (CMP LE, NE)
3038 WordGtOp -> (CMP ULE, EQQ)
3039 WordGeOp -> (CMP ULT, EQQ)
3040 WordEqOp -> (CMP EQQ, NE)
3041 WordNeOp -> (CMP EQQ, EQQ)
3042 WordLtOp -> (CMP ULT, NE)
3043 WordLeOp -> (CMP ULE, NE)
3044 AddrGtOp -> (CMP ULE, EQQ)
3045 AddrGeOp -> (CMP ULT, EQQ)
3046 AddrEqOp -> (CMP EQQ, NE)
3047 AddrNeOp -> (CMP EQQ, EQQ)
3048 AddrLtOp -> (CMP ULT, NE)
3049 AddrLeOp -> (CMP ULE, NE)
3051 #endif {- alpha_TARGET_ARCH -}
3053 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3055 #if i386_TARGET_ARCH
3057 genCondJump lbl bool
3058 = getCondCode bool `thenNat` \ condition ->
3060 code = condCode condition
3061 cond = condName condition
3063 returnNat (code `snocOL` JXX cond lbl)
3065 #endif {- i386_TARGET_ARCH -}
3067 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3069 #if sparc_TARGET_ARCH
3071 genCondJump lbl bool
3072 = getCondCode bool `thenNat` \ condition ->
3074 code = condCode condition
3075 cond = condName condition
3076 target = ImmCLbl lbl
3081 if condFloat condition
3082 then [NOP, BF cond False target, NOP]
3083 else [BI cond False target, NOP]
3087 #endif {- sparc_TARGET_ARCH -}
3089 #if powerpc_TARGET_ARCH
3091 genCondJump lbl bool
3092 = getCondCode bool `thenNat` \ condition ->
3094 code = condCode condition
3095 cond = condName condition
3096 target = ImmCLbl lbl
3099 code `snocOL` BCC cond lbl )
3101 #endif {- powerpc_TARGET_ARCH -}
3103 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3105 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3108 %************************************************************************
3110 \subsection{Generating C calls}
3112 %************************************************************************
3114 Now the biggest nightmare---calls. Most of the nastiness is buried in
3115 @get_arg@, which moves the arguments to the correct registers/stack
3116 locations. Apart from that, the code is easy.
3118 (If applicable) Do not fill the delay slots here; you will confuse the
3123 :: (Either FastString StixExpr) -- function to call
3125 -> PrimRep -- type of the result
3126 -> [StixExpr] -- arguments (of mixed type)
3129 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3131 #if alpha_TARGET_ARCH
3133 genCCall fn cconv kind args
3134 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3135 `thenNat` \ ((unused,_), argCode) ->
3137 nRegs = length allArgRegs - length unused
3138 code = asmSeqThen (map ($ []) argCode)
3141 LDA pv (AddrImm (ImmLab (ptext fn))),
3142 JSR ra (AddrReg pv) nRegs,
3143 LDGP gp (AddrReg ra)]
3145 ------------------------
3146 {- Try to get a value into a specific register (or registers) for
3147 a call. The first 6 arguments go into the appropriate
3148 argument register (separate registers for integer and floating
3149 point arguments, but used in lock-step), and the remaining
3150 arguments are dumped to the stack, beginning at 0(sp). Our
3151 first argument is a pair of the list of remaining argument
3152 registers to be assigned for this call and the next stack
3153 offset to use for overflowing arguments. This way,
3154 @get_Arg@ can be applied to all of a call's arguments using
3158 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3159 -> StixTree -- Current argument
3160 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3162 -- We have to use up all of our argument registers first...
3164 get_arg ((iDst,fDst):dsts, offset) arg
3165 = getRegister arg `thenNat` \ register ->
3167 reg = if isFloatingRep pk then fDst else iDst
3168 code = registerCode register reg
3169 src = registerName register reg
3170 pk = registerRep register
3173 if isFloatingRep pk then
3174 ((dsts, offset), if isFixed register then
3175 code . mkSeqInstr (FMOV src fDst)
3178 ((dsts, offset), if isFixed register then
3179 code . mkSeqInstr (OR src (RIReg src) iDst)
3182 -- Once we have run out of argument registers, we move to the
3185 get_arg ([], offset) arg
3186 = getRegister arg `thenNat` \ register ->
3187 getNewRegNCG (registerRep register)
3190 code = registerCode register tmp
3191 src = registerName register tmp
3192 pk = registerRep register
3193 sz = primRepToSize pk
3195 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3197 #endif {- alpha_TARGET_ARCH -}
3199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3201 #if i386_TARGET_ARCH
3203 genCCall fn cconv ret_rep args
3205 (reverse args) `thenNat` \ sizes_n_codes ->
3206 getDeltaNat `thenNat` \ delta ->
3207 let (sizes, push_codes) = unzip sizes_n_codes
3208 tot_arg_size = sum sizes
3210 -- deal with static vs dynamic call targets
3213 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3215 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3216 ASSERT(case dyn_rep of { L -> True; _ -> False})
3217 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3219 `thenNat` \ callinsns ->
3220 let push_code = concatOL push_codes
3221 call = callinsns `appOL`
3223 -- Deallocate parameters after call for ccall;
3224 -- but not for stdcall (callee does it)
3225 (if cconv == StdCallConv then [] else
3226 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3228 [DELTA (delta + tot_arg_size)]
3231 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3232 returnNat (push_code `appOL` call)
3235 -- function names that begin with '.' are assumed to be special
3236 -- internally generated names like '.mul,' which don't get an
3237 -- underscore prefix
3238 -- ToDo:needed (WDP 96/03) ???
3239 fn_u = unpackFS (unLeft fn)
3242 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3243 | otherwise -- General case
3244 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3246 stdcallsize tot_arg_size
3247 | cconv == StdCallConv = '@':show tot_arg_size
3255 push_arg :: StixExpr{-current argument-}
3256 -> NatM (Int, InstrBlock) -- argsz, code
3259 | is64BitRep arg_rep
3260 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3261 getDeltaNat `thenNat` \ delta ->
3262 setDeltaNat (delta - 8) `thenNat` \ _ ->
3263 let r_lo = VirtualRegI vr_lo
3264 r_hi = getHiVRegFromLo r_lo
3267 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3268 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3271 = get_op arg `thenNat` \ (code, reg, sz) ->
3272 getDeltaNat `thenNat` \ delta ->
3273 arg_size sz `bind` \ size ->
3274 setDeltaNat (delta-size) `thenNat` \ _ ->
3275 if (case sz of DF -> True; F -> True; _ -> False)
3276 then returnNat (size,
3278 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3280 GST sz reg (AddrBaseIndex (Just esp)
3284 else returnNat (size,
3286 PUSH L (OpReg reg) `snocOL`
3290 arg_rep = repOfStixExpr arg
3295 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3298 = getRegister op `thenNat` \ register ->
3299 getNewRegNCG (registerRep register)
3302 code = registerCode register tmp
3303 reg = registerName register tmp
3304 pk = registerRep register
3305 sz = primRepToSize pk
3307 returnNat (code, reg, sz)
3309 #endif {- i386_TARGET_ARCH -}
3311 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3313 #if sparc_TARGET_ARCH
3315 The SPARC calling convention is an absolute
3316 nightmare. The first 6x32 bits of arguments are mapped into
3317 %o0 through %o5, and the remaining arguments are dumped to the
3318 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3320 If we have to put args on the stack, move %o6==%sp down by
3321 the number of words to go on the stack, to ensure there's enough space.
3323 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3324 16 words above the stack pointer is a word for the address of
3325 a structure return value. I use this as a temporary location
3326 for moving values from float to int regs. Certainly it isn't
3327 safe to put anything in the 16 words starting at %sp, since
3328 this area can get trashed at any time due to window overflows
3329 caused by signal handlers.
3331 A final complication (if the above isn't enough) is that
3332 we can't blithely calculate the arguments one by one into
3333 %o0 .. %o5. Consider the following nested calls:
3337 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3338 the inner call will itself use %o0, which trashes the value put there
3339 in preparation for the outer call. Upshot: we need to calculate the
3340 args into temporary regs, and move those to arg regs or onto the
3341 stack only immediately prior to the call proper. Sigh.
3344 genCCall fn cconv kind args
3345 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3347 (argcodes, vregss) = unzip argcode_and_vregs
3348 n_argRegs = length allArgRegs
3349 n_argRegs_used = min (length vregs) n_argRegs
3350 vregs = concat vregss
3352 -- deal with static vs dynamic call targets
3355 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3357 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3358 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3360 `thenNat` \ callinsns ->
3362 argcode = concatOL argcodes
3363 (move_sp_down, move_sp_up)
3364 = let diff = length vregs - n_argRegs
3365 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3368 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3370 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3372 returnNat (argcode `appOL`
3373 move_sp_down `appOL`
3374 transfer_code `appOL`
3379 -- function names that begin with '.' are assumed to be special
3380 -- internally generated names like '.mul,' which don't get an
3381 -- underscore prefix
3382 -- ToDo:needed (WDP 96/03) ???
3383 fn_static = unLeft fn
3384 fn__2 = case (headFS fn_static) of
3385 '.' -> ImmLit (ftext fn_static)
3386 _ -> ImmLab False (ftext fn_static)
3388 -- move args from the integer vregs into which they have been
3389 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3390 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3392 move_final [] _ offset -- all args done
3395 move_final (v:vs) [] offset -- out of aregs; move to stack
3396 = ST W v (spRel offset)
3397 : move_final vs [] (offset+1)
3399 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3400 = OR False g0 (RIReg v) a
3401 : move_final vs az offset
3403 -- generate code to calculate an argument, and move it into one
3404 -- or two integer vregs.
3405 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3406 arg_to_int_vregs arg
3407 | is64BitRep (repOfStixExpr arg)
3408 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3409 let r_lo = VirtualRegI vr_lo
3410 r_hi = getHiVRegFromLo r_lo
3411 in returnNat (code, [r_hi, r_lo])
3413 = getRegister arg `thenNat` \ register ->
3414 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3415 let code = registerCode register tmp
3416 src = registerName register tmp
3417 pk = registerRep register
3419 -- the value is in src. Get it into 1 or 2 int vregs.
3422 getNewRegNCG WordRep `thenNat` \ v1 ->
3423 getNewRegNCG WordRep `thenNat` \ v2 ->
3426 FMOV DF src f0 `snocOL`
3427 ST F f0 (spRel 16) `snocOL`
3428 LD W (spRel 16) v1 `snocOL`
3429 ST F (fPair f0) (spRel 16) `snocOL`
3435 getNewRegNCG WordRep `thenNat` \ v1 ->
3438 ST F src (spRel 16) `snocOL`
3444 getNewRegNCG WordRep `thenNat` \ v1 ->
3446 code `snocOL` OR False g0 (RIReg src) v1
3450 #endif {- sparc_TARGET_ARCH -}
3452 #if powerpc_TARGET_ARCH
3454 The PowerPC calling convention (at least for Darwin/Mac OS X)
3455 is described in Apple's document
3456 "Inside Mac OS X - Mach-O Runtime Architecture".
3457 Parameters may be passed in general-purpose registers, in
3458 floating point registers, or on the stack. Stack space is
3459 always reserved for parameters, even if they are passed in registers.
3460 The called routine may choose to save parameters from registers
3461 to the corresponding space on the stack.
3462 The parameter area should be part of the caller's stack frame,
3463 allocated in the caller's prologue code (large enough to hold
3464 the parameter lists for all called routines). The NCG already
3465 uses the space that we should use as a parameter area for register
3466 spilling, so we allocate a new stack frame just before ccalling.
3467 That way we don't need to decide beforehand how much space to
3468 reserve for parameters.
3471 genCCall fn cconv kind args
3472 = mapNat prepArg args `thenNat` \ preppedArgs ->
3474 (argReps,argCodes,vregs) = unzip3 preppedArgs
3476 -- size of linkage area + size of arguments, in bytes
3477 stackDelta = roundTo16 $ (24 +) $ (4 *) $ sum $ map getPrimRepSize argReps
3478 roundTo16 x | x `mod` 16 == 0 = x
3479 | otherwise = x + 16 - (x `mod` 16)
3481 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3482 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3484 (moveFinalCode,usedRegs) = move_final
3486 allArgRegs allFPArgRegs
3490 passArguments = concatOL argCodes
3491 `appOL` move_sp_down
3492 `appOL` moveFinalCode
3495 Left lbl -> returnNat ( passArguments
3496 `snocOL` BL (ImmLab False (ftext lbl)) usedRegs
3499 getRegister dyn `thenNat` \ dynReg ->
3500 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3501 returnNat (registerCode dynReg tmp
3502 `appOL` passArguments
3503 `snocOL` MTCTR (registerName dynReg tmp)
3504 `snocOL` BCTRL usedRegs
3508 | is64BitRep (repOfStixExpr arg)
3509 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3510 let r_lo = VirtualRegI vr_lo
3511 r_hi = getHiVRegFromLo r_lo
3512 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3514 = getRegister arg `thenNat` \ register ->
3515 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3516 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3517 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3518 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3519 | not (is64BitRep rep) =
3522 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3525 fpr : fprs -> MR fpr vr
3526 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3527 ((take 1 fprs) ++ accumUsed)
3529 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3532 fpr : fprs -> MR fpr vr
3533 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3534 ((take 1 fprs) ++ accumUsed)
3535 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3537 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3540 gpr : gprs -> MR gpr vr
3541 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3542 ((take 1 gprs) ++ accumUsed)
3544 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3547 storeWord vr (gpr:_) offset = MR gpr vr
3548 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3550 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3552 `snocOL` storeWord vr_hi gprs stackOffset
3553 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3554 ((take 2 gprs) ++ accumUsed)
3555 #endif {- powerpc_TARGET_ARCH -}
3557 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3560 %************************************************************************
3562 \subsection{Support bits}
3564 %************************************************************************
3566 %************************************************************************
3568 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3570 %************************************************************************
3572 Turn those condition codes into integers now (when they appear on
3573 the right hand side of an assignment).
3575 (If applicable) Do not fill the delay slots here; you will confuse the
3579 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3581 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3583 #if alpha_TARGET_ARCH
3584 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3585 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3586 #endif {- alpha_TARGET_ARCH -}
3588 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3590 #if i386_TARGET_ARCH
3593 = condIntCode cond x y `thenNat` \ condition ->
3594 getNewRegNCG IntRep `thenNat` \ tmp ->
3596 code = condCode condition
3597 cond = condName condition
3598 code__2 dst = code `appOL` toOL [
3599 SETCC cond (OpReg tmp),
3600 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3601 MOV L (OpReg tmp) (OpReg dst)]
3603 returnNat (Any IntRep code__2)
3606 = getNatLabelNCG `thenNat` \ lbl1 ->
3607 getNatLabelNCG `thenNat` \ lbl2 ->
3608 condFltCode cond x y `thenNat` \ condition ->
3610 code = condCode condition
3611 cond = condName condition
3612 code__2 dst = code `appOL` toOL [
3614 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3617 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3620 returnNat (Any IntRep code__2)
3622 #endif {- i386_TARGET_ARCH -}
3624 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3626 #if sparc_TARGET_ARCH
3628 condIntReg EQQ x (StInt 0)
3629 = getRegister x `thenNat` \ register ->
3630 getNewRegNCG IntRep `thenNat` \ tmp ->
3632 code = registerCode register tmp
3633 src = registerName register tmp
3634 code__2 dst = code `appOL` toOL [
3635 SUB False True g0 (RIReg src) g0,
3636 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3638 returnNat (Any IntRep code__2)
3641 = getRegister x `thenNat` \ register1 ->
3642 getRegister y `thenNat` \ register2 ->
3643 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3644 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3646 code1 = registerCode register1 tmp1
3647 src1 = registerName register1 tmp1
3648 code2 = registerCode register2 tmp2
3649 src2 = registerName register2 tmp2
3650 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3651 XOR False src1 (RIReg src2) dst,
3652 SUB False True g0 (RIReg dst) g0,
3653 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3655 returnNat (Any IntRep code__2)
3657 condIntReg NE x (StInt 0)
3658 = getRegister x `thenNat` \ register ->
3659 getNewRegNCG IntRep `thenNat` \ tmp ->
3661 code = registerCode register tmp
3662 src = registerName register tmp
3663 code__2 dst = code `appOL` toOL [
3664 SUB False True g0 (RIReg src) g0,
3665 ADD True False g0 (RIImm (ImmInt 0)) dst]
3667 returnNat (Any IntRep code__2)
3670 = getRegister x `thenNat` \ register1 ->
3671 getRegister y `thenNat` \ register2 ->
3672 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3673 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3675 code1 = registerCode register1 tmp1
3676 src1 = registerName register1 tmp1
3677 code2 = registerCode register2 tmp2
3678 src2 = registerName register2 tmp2
3679 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3680 XOR False src1 (RIReg src2) dst,
3681 SUB False True g0 (RIReg dst) g0,
3682 ADD True False g0 (RIImm (ImmInt 0)) dst]
3684 returnNat (Any IntRep code__2)
3687 = getNatLabelNCG `thenNat` \ lbl1 ->
3688 getNatLabelNCG `thenNat` \ lbl2 ->
3689 condIntCode cond x y `thenNat` \ condition ->
3691 code = condCode condition
3692 cond = condName condition
3693 code__2 dst = code `appOL` toOL [
3694 BI cond False (ImmCLbl lbl1), NOP,
3695 OR False g0 (RIImm (ImmInt 0)) dst,
3696 BI ALWAYS False (ImmCLbl lbl2), NOP,
3698 OR False g0 (RIImm (ImmInt 1)) dst,
3701 returnNat (Any IntRep code__2)
3704 = getNatLabelNCG `thenNat` \ lbl1 ->
3705 getNatLabelNCG `thenNat` \ lbl2 ->
3706 condFltCode cond x y `thenNat` \ condition ->
3708 code = condCode condition
3709 cond = condName condition
3710 code__2 dst = code `appOL` toOL [
3712 BF cond False (ImmCLbl lbl1), NOP,
3713 OR False g0 (RIImm (ImmInt 0)) dst,
3714 BI ALWAYS False (ImmCLbl lbl2), NOP,
3716 OR False g0 (RIImm (ImmInt 1)) dst,
3719 returnNat (Any IntRep code__2)
3721 #endif {- sparc_TARGET_ARCH -}
3723 #if powerpc_TARGET_ARCH
3725 = getNatLabelNCG `thenNat` \ lbl ->
3726 condIntCode cond x y `thenNat` \ condition ->
3728 code = condCode condition
3729 cond = condName condition
3730 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3735 returnNat (Any IntRep code__2)
3738 = getNatLabelNCG `thenNat` \ lbl ->
3739 condFltCode cond x y `thenNat` \ condition ->
3741 code = condCode condition
3742 cond = condName condition
3743 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3748 returnNat (Any IntRep code__2)
3749 #endif {- powerpc_TARGET_ARCH -}
3751 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3754 %************************************************************************
3756 \subsubsection{@trivial*Code@: deal with trivial instructions}
3758 %************************************************************************
3760 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3761 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3762 for constants on the right hand side, because that's where the generic
3763 optimizer will have put them.
3765 Similarly, for unary instructions, we don't have to worry about
3766 matching an StInt as the argument, because genericOpt will already
3767 have handled the constant-folding.
3771 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3772 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3773 -> Maybe (Operand -> Operand -> Instr)
3774 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3775 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3777 -> StixExpr -> StixExpr -- the two arguments
3782 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3783 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3784 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3785 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3787 -> StixExpr -> StixExpr -- the two arguments
3791 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3792 ,IF_ARCH_i386 ((Operand -> Instr)
3793 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3794 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3796 -> StixExpr -- the one argument
3801 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3802 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3803 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3804 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3806 -> StixExpr -- the one argument
3809 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3811 #if alpha_TARGET_ARCH
3813 trivialCode instr x (StInt y)
3815 = getRegister x `thenNat` \ register ->
3816 getNewRegNCG IntRep `thenNat` \ tmp ->
3818 code = registerCode register tmp
3819 src1 = registerName register tmp
3820 src2 = ImmInt (fromInteger y)
3821 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3823 returnNat (Any IntRep code__2)
3825 trivialCode instr x y
3826 = getRegister x `thenNat` \ register1 ->
3827 getRegister y `thenNat` \ register2 ->
3828 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3829 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3831 code1 = registerCode register1 tmp1 []
3832 src1 = registerName register1 tmp1
3833 code2 = registerCode register2 tmp2 []
3834 src2 = registerName register2 tmp2
3835 code__2 dst = asmSeqThen [code1, code2] .
3836 mkSeqInstr (instr src1 (RIReg src2) dst)
3838 returnNat (Any IntRep code__2)
3841 trivialUCode instr x
3842 = getRegister x `thenNat` \ register ->
3843 getNewRegNCG IntRep `thenNat` \ tmp ->
3845 code = registerCode register tmp
3846 src = registerName register tmp
3847 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3849 returnNat (Any IntRep code__2)
3852 trivialFCode _ instr x y
3853 = getRegister x `thenNat` \ register1 ->
3854 getRegister y `thenNat` \ register2 ->
3855 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3856 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3858 code1 = registerCode register1 tmp1
3859 src1 = registerName register1 tmp1
3861 code2 = registerCode register2 tmp2
3862 src2 = registerName register2 tmp2
3864 code__2 dst = asmSeqThen [code1 [], code2 []] .
3865 mkSeqInstr (instr src1 src2 dst)
3867 returnNat (Any DoubleRep code__2)
3869 trivialUFCode _ instr x
3870 = getRegister x `thenNat` \ register ->
3871 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3873 code = registerCode register tmp
3874 src = registerName register tmp
3875 code__2 dst = code . mkSeqInstr (instr src dst)
3877 returnNat (Any DoubleRep code__2)
3879 #endif {- alpha_TARGET_ARCH -}
3881 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3883 #if i386_TARGET_ARCH
3885 The Rules of the Game are:
3887 * You cannot assume anything about the destination register dst;
3888 it may be anything, including a fixed reg.
3890 * You may compute an operand into a fixed reg, but you may not
3891 subsequently change the contents of that fixed reg. If you
3892 want to do so, first copy the value either to a temporary
3893 or into dst. You are free to modify dst even if it happens
3894 to be a fixed reg -- that's not your problem.
3896 * You cannot assume that a fixed reg will stay live over an
3897 arbitrary computation. The same applies to the dst reg.
3899 * Temporary regs obtained from getNewRegNCG are distinct from
3900 each other and from all other regs, and stay live over
3901 arbitrary computations.
3905 trivialCode instr maybe_revinstr a b
3908 = getRegister a `thenNat` \ rega ->
3911 then registerCode rega dst `bind` \ code_a ->
3913 instr (OpImm imm_b) (OpReg dst)
3914 else registerCodeF rega `bind` \ code_a ->
3915 registerNameF rega `bind` \ r_a ->
3917 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3918 instr (OpImm imm_b) (OpReg dst)
3920 returnNat (Any IntRep mkcode)
3923 = getRegister b `thenNat` \ regb ->
3924 getNewRegNCG IntRep `thenNat` \ tmp ->
3925 let revinstr_avail = maybeToBool maybe_revinstr
3926 revinstr = case maybe_revinstr of Just ri -> ri
3930 then registerCode regb dst `bind` \ code_b ->
3932 revinstr (OpImm imm_a) (OpReg dst)
3933 else registerCodeF regb `bind` \ code_b ->
3934 registerNameF regb `bind` \ r_b ->
3936 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3937 revinstr (OpImm imm_a) (OpReg dst)
3941 then registerCode regb tmp `bind` \ code_b ->
3943 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3944 instr (OpReg tmp) (OpReg dst)
3945 else registerCodeF regb `bind` \ code_b ->
3946 registerNameF regb `bind` \ r_b ->
3948 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3949 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3950 instr (OpReg tmp) (OpReg dst)
3952 returnNat (Any IntRep mkcode)
3955 = getRegister a `thenNat` \ rega ->
3956 getRegister b `thenNat` \ regb ->
3957 getNewRegNCG IntRep `thenNat` \ tmp ->
3959 = case (isAny rega, isAny regb) of
3961 -> registerCode regb tmp `bind` \ code_b ->
3962 registerCode rega dst `bind` \ code_a ->
3965 instr (OpReg tmp) (OpReg dst)
3967 -> registerCode rega tmp `bind` \ code_a ->
3968 registerCodeF regb `bind` \ code_b ->
3969 registerNameF regb `bind` \ r_b ->
3972 instr (OpReg r_b) (OpReg tmp) `snocOL`
3973 MOV L (OpReg tmp) (OpReg dst)
3975 -> registerCode regb tmp `bind` \ code_b ->
3976 registerCodeF rega `bind` \ code_a ->
3977 registerNameF rega `bind` \ r_a ->
3980 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3981 instr (OpReg tmp) (OpReg dst)
3983 -> registerCodeF rega `bind` \ code_a ->
3984 registerNameF rega `bind` \ r_a ->
3985 registerCodeF regb `bind` \ code_b ->
3986 registerNameF regb `bind` \ r_b ->
3988 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3990 instr (OpReg r_b) (OpReg tmp) `snocOL`
3991 MOV L (OpReg tmp) (OpReg dst)
3993 returnNat (Any IntRep mkcode)
3996 maybe_imm_a = maybeImm a
3997 is_imm_a = maybeToBool maybe_imm_a
3998 imm_a = case maybe_imm_a of Just imm -> imm
4000 maybe_imm_b = maybeImm b
4001 is_imm_b = maybeToBool maybe_imm_b
4002 imm_b = case maybe_imm_b of Just imm -> imm
4006 trivialUCode instr x
4007 = getRegister x `thenNat` \ register ->
4009 code__2 dst = let code = registerCode register dst
4010 src = registerName register dst
4012 if isFixed register && dst /= src
4013 then toOL [MOV L (OpReg src) (OpReg dst),
4015 else unitOL (instr (OpReg src))
4017 returnNat (Any IntRep code__2)
4020 trivialFCode pk instr x y
4021 = getRegister x `thenNat` \ register1 ->
4022 getRegister y `thenNat` \ register2 ->
4023 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4024 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4026 code1 = registerCode register1 tmp1
4027 src1 = registerName register1 tmp1
4029 code2 = registerCode register2 tmp2
4030 src2 = registerName register2 tmp2
4033 -- treat the common case specially: both operands in
4035 | isAny register1 && isAny register2
4038 instr (primRepToSize pk) src1 src2 dst
4040 -- be paranoid (and inefficient)
4042 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4044 instr (primRepToSize pk) tmp1 src2 dst
4046 returnNat (Any pk code__2)
4050 trivialUFCode pk instr x
4051 = getRegister x `thenNat` \ register ->
4052 getNewRegNCG pk `thenNat` \ tmp ->
4054 code = registerCode register tmp
4055 src = registerName register tmp
4056 code__2 dst = code `snocOL` instr src dst
4058 returnNat (Any pk code__2)
4060 #endif {- i386_TARGET_ARCH -}
4062 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4064 #if sparc_TARGET_ARCH
4066 trivialCode instr x (StInt y)
4068 = getRegister x `thenNat` \ register ->
4069 getNewRegNCG IntRep `thenNat` \ tmp ->
4071 code = registerCode register tmp
4072 src1 = registerName register tmp
4073 src2 = ImmInt (fromInteger y)
4074 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4076 returnNat (Any IntRep code__2)
4078 trivialCode instr x y
4079 = getRegister x `thenNat` \ register1 ->
4080 getRegister y `thenNat` \ register2 ->
4081 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4082 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4084 code1 = registerCode register1 tmp1
4085 src1 = registerName register1 tmp1
4086 code2 = registerCode register2 tmp2
4087 src2 = registerName register2 tmp2
4088 code__2 dst = code1 `appOL` code2 `snocOL`
4089 instr src1 (RIReg src2) dst
4091 returnNat (Any IntRep code__2)
4094 trivialFCode pk instr x y
4095 = getRegister x `thenNat` \ register1 ->
4096 getRegister y `thenNat` \ register2 ->
4097 getNewRegNCG (registerRep register1)
4099 getNewRegNCG (registerRep register2)
4101 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4103 promote x = FxTOy F DF x tmp
4105 pk1 = registerRep register1
4106 code1 = registerCode register1 tmp1
4107 src1 = registerName register1 tmp1
4109 pk2 = registerRep register2
4110 code2 = registerCode register2 tmp2
4111 src2 = registerName register2 tmp2
4115 code1 `appOL` code2 `snocOL`
4116 instr (primRepToSize pk) src1 src2 dst
4117 else if pk1 == FloatRep then
4118 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4119 instr DF tmp src2 dst
4121 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4122 instr DF src1 tmp dst
4124 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4127 trivialUCode instr x
4128 = getRegister x `thenNat` \ register ->
4129 getNewRegNCG IntRep `thenNat` \ tmp ->
4131 code = registerCode register tmp
4132 src = registerName register tmp
4133 code__2 dst = code `snocOL` instr (RIReg src) dst
4135 returnNat (Any IntRep code__2)
4138 trivialUFCode pk instr x
4139 = getRegister x `thenNat` \ register ->
4140 getNewRegNCG pk `thenNat` \ tmp ->
4142 code = registerCode register tmp
4143 src = registerName register tmp
4144 code__2 dst = code `snocOL` instr src dst
4146 returnNat (Any pk code__2)
4148 #endif {- sparc_TARGET_ARCH -}
4150 #if powerpc_TARGET_ARCH
4151 trivialCode instr x (StInt y)
4153 = getRegister x `thenNat` \ register ->
4154 getNewRegNCG IntRep `thenNat` \ tmp ->
4156 code = registerCode register tmp
4157 src1 = registerName register tmp
4158 src2 = ImmInt (fromInteger y)
4159 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4161 returnNat (Any IntRep code__2)
4163 trivialCode instr x y
4164 = getRegister x `thenNat` \ register1 ->
4165 getRegister y `thenNat` \ register2 ->
4166 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4167 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4169 code1 = registerCode register1 tmp1
4170 src1 = registerName register1 tmp1
4171 code2 = registerCode register2 tmp2
4172 src2 = registerName register2 tmp2
4173 code__2 dst = code1 `appOL` code2 `snocOL`
4174 instr dst src1 (RIReg src2)
4176 returnNat (Any IntRep code__2)
4178 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4179 -> StixExpr -> StixExpr -> NatM Register
4180 trivialCode2 instr x y
4181 = getRegister x `thenNat` \ register1 ->
4182 getRegister y `thenNat` \ register2 ->
4183 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4184 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4186 code1 = registerCode register1 tmp1
4187 src1 = registerName register1 tmp1
4188 code2 = registerCode register2 tmp2
4189 src2 = registerName register2 tmp2
4190 code__2 dst = code1 `appOL` code2 `snocOL`
4193 returnNat (Any IntRep code__2)
4195 trivialFCode pk instr x y
4196 = getRegister x `thenNat` \ register1 ->
4197 getRegister y `thenNat` \ register2 ->
4198 getNewRegNCG (registerRep register1)
4200 getNewRegNCG (registerRep register2)
4202 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4204 -- promote x = FxTOy F DF x tmp
4206 pk1 = registerRep register1
4207 code1 = registerCode register1 tmp1
4208 src1 = registerName register1 tmp1
4210 pk2 = registerRep register2
4211 code2 = registerCode register2 tmp2
4212 src2 = registerName register2 tmp2
4216 code1 `appOL` code2 `snocOL`
4217 instr (primRepToSize pk) src1 src2 dst
4218 else panic "###PPC MachCode.trivialFCode: type mismatch"
4220 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4222 trivialUCode instr x
4223 = getRegister x `thenNat` \ register ->
4224 getNewRegNCG IntRep `thenNat` \ tmp ->
4226 code = registerCode register tmp
4227 src = registerName register tmp
4228 code__2 dst = code `snocOL` instr dst src
4230 returnNat (Any IntRep code__2)
4231 trivialUFCode pk instr x = panic "###PPC MachCode.trivialUFCode"
4232 #endif {- powerpc_TARGET_ARCH -}
4234 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4237 %************************************************************************
4239 \subsubsection{Coercing to/from integer/floating-point...}
4241 %************************************************************************
4243 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4244 conversions. We have to store temporaries in memory to move
4245 between the integer and the floating point register sets.
4247 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4248 pretend, on sparc at least, that double and float regs are seperate
4249 kinds, so the value has to be computed into one kind before being
4250 explicitly "converted" to live in the other kind.
4253 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4254 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4256 coerceDbl2Flt :: StixExpr -> NatM Register
4257 coerceFlt2Dbl :: StixExpr -> NatM Register
4261 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4263 #if alpha_TARGET_ARCH
4266 = getRegister x `thenNat` \ register ->
4267 getNewRegNCG IntRep `thenNat` \ reg ->
4269 code = registerCode register reg
4270 src = registerName register reg
4272 code__2 dst = code . mkSeqInstrs [
4274 LD TF dst (spRel 0),
4277 returnNat (Any DoubleRep code__2)
4281 = getRegister x `thenNat` \ register ->
4282 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4284 code = registerCode register tmp
4285 src = registerName register tmp
4287 code__2 dst = code . mkSeqInstrs [
4289 ST TF tmp (spRel 0),
4292 returnNat (Any IntRep code__2)
4294 #endif {- alpha_TARGET_ARCH -}
4296 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4298 #if i386_TARGET_ARCH
4301 = getRegister x `thenNat` \ register ->
4302 getNewRegNCG IntRep `thenNat` \ reg ->
4304 code = registerCode register reg
4305 src = registerName register reg
4306 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4307 code__2 dst = code `snocOL` opc src dst
4309 returnNat (Any pk code__2)
4312 coerceFP2Int fprep x
4313 = getRegister x `thenNat` \ register ->
4314 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4316 code = registerCode register tmp
4317 src = registerName register tmp
4318 pk = registerRep register
4320 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4321 code__2 dst = code `snocOL` opc src dst
4323 returnNat (Any IntRep code__2)
4326 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4327 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4329 #endif {- i386_TARGET_ARCH -}
4331 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4333 #if sparc_TARGET_ARCH
4336 = getRegister x `thenNat` \ register ->
4337 getNewRegNCG IntRep `thenNat` \ reg ->
4339 code = registerCode register reg
4340 src = registerName register reg
4342 code__2 dst = code `appOL` toOL [
4343 ST W src (spRel (-2)),
4344 LD W (spRel (-2)) dst,
4345 FxTOy W (primRepToSize pk) dst dst]
4347 returnNat (Any pk code__2)
4350 coerceFP2Int fprep x
4351 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4352 getRegister x `thenNat` \ register ->
4353 getNewRegNCG fprep `thenNat` \ reg ->
4354 getNewRegNCG FloatRep `thenNat` \ tmp ->
4356 code = registerCode register reg
4357 src = registerName register reg
4358 code__2 dst = code `appOL` toOL [
4359 FxTOy (primRepToSize fprep) W src tmp,
4360 ST W tmp (spRel (-2)),
4361 LD W (spRel (-2)) dst]
4363 returnNat (Any IntRep code__2)
4367 = getRegister x `thenNat` \ register ->
4368 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4369 let code = registerCode register tmp
4370 src = registerName register tmp
4372 returnNat (Any FloatRep
4373 (\dst -> code `snocOL` FxTOy DF F src dst))
4377 = getRegister x `thenNat` \ register ->
4378 getNewRegNCG FloatRep `thenNat` \ tmp ->
4379 let code = registerCode register tmp
4380 src = registerName register tmp
4382 returnNat (Any DoubleRep
4383 (\dst -> code `snocOL` FxTOy F DF src dst))
4385 #endif {- sparc_TARGET_ARCH -}
4387 #if powerpc_TARGET_ARCH
4388 coerceInt2FP pk x = panic "###PPC MachCode.coerceInt2FP"
4389 coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int"
4390 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4391 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4392 #endif {- powerpc_TARGET_ARCH -}
4394 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -