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 MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import MachOp ( MachOp(..), pprMachOp )
22 import AbsCUtils ( magicIdPrimRep )
23 import PprAbsC ( pprMagicId )
24 import ForeignCall ( CCallConv(..) )
25 import CLabel ( CLabel, labelDynamic )
26 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
27 import CLabel ( isAsmTemp )
29 import Maybes ( maybeToBool )
30 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
31 #if powerpc_TARGET_ARCH
34 getPrimRepSizeInBytes )
35 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
36 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
37 DestInfo, hasDestInfo,
38 pprStixExpr, repOfStixExpr,
39 NatM, thenNat, returnNat, mapNat,
40 mapAndUnzipNat, mapAccumLNat,
41 getDeltaNat, setDeltaNat,
42 IF_ARCH_powerpc(addImportNat COMMA,)
47 import Outputable ( panic, pprPanic, showSDoc )
48 import qualified Outputable
49 import CmdLineOpts ( opt_Static )
50 import Stix ( pprStixStmt )
52 import Maybe ( fromMaybe )
55 import Outputable ( assertPanic )
57 import TRACE ( trace )
62 @InstrBlock@s are the insn sequences generated by the insn selectors.
63 They are really trees of insns to facilitate fast appending, where a
64 left-to-right traversal (pre-order?) yields the insns in the correct
68 type InstrBlock = OrdList Instr
72 isLeft (Left _) = True
73 isLeft (Right _) = False
78 Code extractor for an entire stix tree---stix statement level.
81 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
83 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
84 returnNat (concatOL instrss)
87 stmtToInstrs :: StixStmt -> NatM InstrBlock
88 stmtToInstrs stmt = case stmt of
89 StComment s -> returnNat (unitOL (COMMENT s))
90 StSegment seg -> returnNat (unitOL (SEGMENT seg))
92 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
94 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
97 StLabel lab -> returnNat (unitOL (LABEL lab))
99 StJump dsts arg -> genJump dsts (derefDLL arg)
100 StCondJump lab arg -> genCondJump lab (derefDLL arg)
102 -- A call returning void, ie one done for its side-effects. Note
103 -- that this is the only StVoidable we handle.
104 StVoidable (StCall fn cconv VoidRep args)
105 -> genCCall fn cconv VoidRep (map derefDLL args)
107 StAssignMem pk addr src
108 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
109 | ncg_target_is_32bit
110 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
111 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
112 StAssignReg pk reg src
113 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
114 | ncg_target_is_32bit
115 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
116 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
119 -- When falling through on the Alpha, we still have to load pv
120 -- with the address of the next routine, so that it can load gp.
121 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
125 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
126 returnNat (DATA (primRepToSize kind) imms
127 `consOL` concatOL codes)
129 getData :: StixExpr -> NatM (InstrBlock, Imm)
130 getData (StInt i) = returnNat (nilOL, ImmInteger i)
131 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
132 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
133 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
134 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
135 -- the linker can handle simple arithmetic...
136 getData (StIndex rep (StCLbl lbl) (StInt off)) =
138 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
140 -- Top-level lifted-out string. The segment will already have been set
141 -- (see Stix.liftStrings).
143 -> returnNat (unitOL (ASCII True (unpackFS str)))
146 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
149 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
150 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
151 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
153 derefDLL :: StixExpr -> StixExpr
155 | opt_Static -- short out the entire deal if not doing DLLs
162 StCLbl lbl -> if labelDynamic lbl
163 then StInd PtrRep (StCLbl lbl)
165 -- all the rest are boring
166 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
167 StMachOp mop args -> StMachOp mop (map qq args)
168 StInd pk addr -> StInd pk (qq addr)
169 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
170 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
176 _ -> pprPanic "derefDLL: unhandled case"
180 %************************************************************************
182 \subsection{General things for putting together code sequences}
184 %************************************************************************
187 mangleIndexTree :: StixExpr -> StixExpr
189 mangleIndexTree (StIndex pk base (StInt i))
190 = StMachOp MO_Nat_Add [base, off]
192 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
194 mangleIndexTree (StIndex pk base off)
195 = StMachOp MO_Nat_Add [
198 in if s == 0 then off
199 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
202 shift :: PrimRep -> Int
203 shift rep = case getPrimRepSizeInBytes rep of
208 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
209 (Outputable.int other)
213 maybeImm :: StixExpr -> Maybe Imm
217 maybeImm (StIndex rep (StCLbl l) (StInt off))
218 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
220 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
221 = Just (ImmInt (fromInteger i))
223 = Just (ImmInteger i)
228 %************************************************************************
230 \subsection{The @Register64@ type}
232 %************************************************************************
234 Simple support for generating 64-bit code (ie, 64 bit values and 64
235 bit assignments) on 32-bit platforms. Unlike the main code generator
236 we merely shoot for generating working code as simply as possible, and
237 pay little attention to code quality. Specifically, there is no
238 attempt to deal cleverly with the fixed-vs-floating register
239 distinction; all values are generated into (pairs of) floating
240 registers, even if this would mean some redundant reg-reg moves as a
241 result. Only one of the VRegUniques is returned, since it will be
242 of the VRegUniqueLo form, and the upper-half VReg can be determined
243 by applying getHiVRegFromLo to it.
247 data ChildCode64 -- a.k.a "Register64"
250 VRegUnique -- unique for the lower 32-bit temporary
251 -- which contains the result; use getHiVRegFromLo to find
252 -- the other VRegUnique.
253 -- Rules of this simplified insn selection game are
254 -- therefore that the returned VRegUnique may be modified
256 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
257 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
258 iselExpr64 :: StixExpr -> NatM ChildCode64
260 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
264 assignMem_I64Code addrTree valueTree
265 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
266 getRegister addrTree `thenNat` \ register_addr ->
267 getNewRegNCG IntRep `thenNat` \ t_addr ->
268 let rlo = VirtualRegI vrlo
269 rhi = getHiVRegFromLo rlo
270 code_addr = registerCode register_addr t_addr
271 reg_addr = registerName register_addr t_addr
272 -- Little-endian store
273 mov_lo = MOV L (OpReg rlo)
274 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
275 mov_hi = MOV L (OpReg rhi)
276 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
278 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
280 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
281 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
283 r_dst_lo = mkVReg u_dst IntRep
284 r_src_lo = VirtualRegI vr_src_lo
285 r_dst_hi = getHiVRegFromLo r_dst_lo
286 r_src_hi = getHiVRegFromLo r_src_lo
287 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
288 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
291 vcode `snocOL` mov_lo `snocOL` mov_hi
294 assignReg_I64Code lvalue valueTree
295 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
300 iselExpr64 (StInd pk addrTree)
302 = getRegister addrTree `thenNat` \ register_addr ->
303 getNewRegNCG IntRep `thenNat` \ t_addr ->
304 getNewRegNCG IntRep `thenNat` \ rlo ->
305 let rhi = getHiVRegFromLo rlo
306 code_addr = registerCode register_addr t_addr
307 reg_addr = registerName register_addr t_addr
308 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
310 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
314 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
318 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
320 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
321 let r_dst_hi = getHiVRegFromLo r_dst_lo
322 r_src_lo = mkVReg vu IntRep
323 r_src_hi = getHiVRegFromLo r_src_lo
324 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
325 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
328 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
331 iselExpr64 (StCall fn cconv kind args)
333 = genCCall fn cconv kind args `thenNat` \ call ->
334 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
335 let r_dst_hi = getHiVRegFromLo r_dst_lo
336 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
337 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
340 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
341 (getVRegUnique r_dst_lo)
345 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
347 #endif /* i386_TARGET_ARCH */
349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
351 #if sparc_TARGET_ARCH
353 assignMem_I64Code addrTree valueTree
354 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
355 getRegister addrTree `thenNat` \ register_addr ->
356 getNewRegNCG IntRep `thenNat` \ t_addr ->
357 let rlo = VirtualRegI vrlo
358 rhi = getHiVRegFromLo rlo
359 code_addr = registerCode register_addr t_addr
360 reg_addr = registerName register_addr t_addr
362 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
363 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
365 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
368 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
369 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
371 r_dst_lo = mkVReg u_dst IntRep
372 r_src_lo = VirtualRegI vr_src_lo
373 r_dst_hi = getHiVRegFromLo r_dst_lo
374 r_src_hi = getHiVRegFromLo r_src_lo
375 mov_lo = mkMOV r_src_lo r_dst_lo
376 mov_hi = mkMOV r_src_hi r_dst_hi
377 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
380 vcode `snocOL` mov_hi `snocOL` mov_lo
382 assignReg_I64Code lvalue valueTree
383 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
387 -- Don't delete this -- it's very handy for debugging.
389 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
390 -- = panic "iselExpr64(???)"
392 iselExpr64 (StInd pk addrTree)
394 = getRegister addrTree `thenNat` \ register_addr ->
395 getNewRegNCG IntRep `thenNat` \ t_addr ->
396 getNewRegNCG IntRep `thenNat` \ rlo ->
397 let rhi = getHiVRegFromLo rlo
398 code_addr = registerCode register_addr t_addr
399 reg_addr = registerName register_addr t_addr
400 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
401 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
404 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
408 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
410 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
411 let r_dst_hi = getHiVRegFromLo r_dst_lo
412 r_src_lo = mkVReg vu IntRep
413 r_src_hi = getHiVRegFromLo r_src_lo
414 mov_lo = mkMOV r_src_lo r_dst_lo
415 mov_hi = mkMOV r_src_hi r_dst_hi
416 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
419 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
422 iselExpr64 (StCall fn cconv kind args)
424 = genCCall fn cconv kind args `thenNat` \ call ->
425 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
426 let r_dst_hi = getHiVRegFromLo r_dst_lo
427 mov_lo = mkMOV o0 r_dst_lo
428 mov_hi = mkMOV o1 r_dst_hi
429 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
432 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
433 (getVRegUnique r_dst_lo)
437 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
439 #endif /* sparc_TARGET_ARCH */
440 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
442 #if powerpc_TARGET_ARCH
444 assignMem_I64Code addrTree valueTree
445 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
446 getRegister addrTree `thenNat` \ register_addr ->
447 getNewRegNCG IntRep `thenNat` \ t_addr ->
448 let rlo = VirtualRegI vrlo
449 rhi = getHiVRegFromLo rlo
450 code_addr = registerCode register_addr t_addr
451 reg_addr = registerName register_addr t_addr
453 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
454 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
456 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
459 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
460 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
462 r_dst_lo = mkVReg u_dst IntRep
463 r_src_lo = VirtualRegI vr_src_lo
464 r_dst_hi = getHiVRegFromLo r_dst_lo
465 r_src_hi = getHiVRegFromLo r_src_lo
466 mov_lo = MR r_dst_lo r_src_lo
467 mov_hi = MR r_dst_hi r_src_hi
470 vcode `snocOL` mov_hi `snocOL` mov_lo
472 assignReg_I64Code lvalue valueTree
473 = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
477 -- Don't delete this -- it's very handy for debugging.
479 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
480 -- = panic "iselExpr64(???)"
482 iselExpr64 (StInd pk addrTree)
484 = getRegister addrTree `thenNat` \ register_addr ->
485 getNewRegNCG IntRep `thenNat` \ t_addr ->
486 getNewRegNCG IntRep `thenNat` \ rlo ->
487 let rhi = getHiVRegFromLo rlo
488 code_addr = registerCode register_addr t_addr
489 reg_addr = registerName register_addr t_addr
490 mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
491 mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
494 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
498 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
500 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
501 let r_dst_hi = getHiVRegFromLo r_dst_lo
502 r_src_lo = mkVReg vu IntRep
503 r_src_hi = getHiVRegFromLo r_src_lo
504 mov_lo = MR r_dst_lo r_src_lo
505 mov_hi = MR r_dst_hi r_src_hi
508 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
511 iselExpr64 (StCall fn cconv kind args)
513 = genCCall fn cconv kind args `thenNat` \ call ->
514 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
515 let r_dst_hi = getHiVRegFromLo r_dst_lo
516 mov_lo = MR r_dst_lo r4
517 mov_hi = MR r_dst_hi r3
520 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
521 (getVRegUnique r_dst_lo)
525 = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
527 #endif /* powerpc_TARGET_ARCH */
529 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
533 %************************************************************************
535 \subsection{The @Register@ type}
537 %************************************************************************
539 @Register@s passed up the tree. If the stix code forces the register
540 to live in a pre-decided machine register, it comes out as @Fixed@;
541 otherwise, it comes out as @Any@, and the parent can decide which
542 register to put it in.
546 = Fixed PrimRep Reg InstrBlock
547 | Any PrimRep (Reg -> InstrBlock)
549 registerCode :: Register -> Reg -> InstrBlock
550 registerCode (Fixed _ _ code) reg = code
551 registerCode (Any _ code) reg = code reg
553 registerCodeF (Fixed _ _ code) = code
554 registerCodeF (Any _ _) = panic "registerCodeF"
556 registerCodeA (Any _ code) = code
557 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
559 registerName :: Register -> Reg -> Reg
560 registerName (Fixed _ reg _) _ = reg
561 registerName (Any _ _) reg = reg
563 registerNameF (Fixed _ reg _) = reg
564 registerNameF (Any _ _) = panic "registerNameF"
566 registerRep :: Register -> PrimRep
567 registerRep (Fixed pk _ _) = pk
568 registerRep (Any pk _) = pk
570 swizzleRegisterRep :: Register -> PrimRep -> Register
571 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
572 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
574 {-# INLINE registerCode #-}
575 {-# INLINE registerCodeF #-}
576 {-# INLINE registerName #-}
577 {-# INLINE registerNameF #-}
578 {-# INLINE registerRep #-}
579 {-# INLINE isFixed #-}
582 isFixed, isAny :: Register -> Bool
583 isFixed (Fixed _ _ _) = True
584 isFixed (Any _ _) = False
586 isAny = not . isFixed
589 Generate code to get a subtree into a @Register@:
592 getRegisterReg :: StixReg -> NatM Register
593 getRegister :: StixExpr -> NatM Register
596 getRegisterReg (StixMagicId mid)
597 = case get_MagicId_reg_or_addr mid of
599 -> let pk = magicIdPrimRep mid
600 in returnNat (Fixed pk (RealReg rrno) nilOL)
602 -- By this stage, the only MagicIds remaining should be the
603 -- ones which map to a real machine register on this platform. Hence ...
604 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
606 getRegisterReg (StixTemp (StixVReg u pk))
607 = returnNat (Fixed pk (mkVReg u pk) nilOL)
611 -- Don't delete this -- it's very handy for debugging.
613 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
614 -- = panic "getRegister(???)"
616 getRegister (StReg reg)
619 getRegister tree@(StIndex _ _ _)
620 = getRegister (mangleIndexTree tree)
622 getRegister (StCall fn cconv kind args)
623 | not (ncg_target_is_32bit && is64BitRep kind)
624 = genCCall fn cconv kind args `thenNat` \ call ->
625 returnNat (Fixed kind reg call)
627 reg = if isFloatingRep kind
628 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
629 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
631 getRegister (StString s)
632 = getNatLabelNCG `thenNat` \ lbl ->
634 imm_lbl = ImmCLbl lbl
637 SEGMENT RoDataSegment,
639 ASCII True (unpackFS s),
641 #if alpha_TARGET_ARCH
642 LDA dst (AddrImm imm_lbl)
645 MOV L (OpImm imm_lbl) (OpReg dst)
647 #if sparc_TARGET_ARCH
648 SETHI (HI imm_lbl) dst,
649 OR False dst (RIImm (LO imm_lbl)) dst
651 #if powerpc_TARGET_ARCH
652 LIS dst (HI imm_lbl),
653 OR dst dst (RIImm (LO imm_lbl))
657 returnNat (Any PtrRep code)
659 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
660 -- end of machine-"independent" bit; here we go on the rest...
662 #if alpha_TARGET_ARCH
664 getRegister (StDouble d)
665 = getNatLabelNCG `thenNat` \ lbl ->
666 getNewRegNCG PtrRep `thenNat` \ tmp ->
667 let code dst = mkSeqInstrs [
670 DATA TF [ImmLab (rational d)],
672 LDA tmp (AddrImm (ImmCLbl lbl)),
673 LD TF dst (AddrReg tmp)]
675 returnNat (Any DoubleRep code)
677 getRegister (StPrim primop [x]) -- unary PrimOps
679 IntNegOp -> trivialUCode (NEG Q False) x
681 NotOp -> trivialUCode NOT x
683 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
684 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
686 OrdOp -> coerceIntCode IntRep x
689 Float2IntOp -> coerceFP2Int x
690 Int2FloatOp -> coerceInt2FP pr x
691 Double2IntOp -> coerceFP2Int x
692 Int2DoubleOp -> coerceInt2FP pr x
694 Double2FloatOp -> coerceFltCode x
695 Float2DoubleOp -> coerceFltCode x
697 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
699 fn = case other_op of
700 FloatExpOp -> FSLIT("exp")
701 FloatLogOp -> FSLIT("log")
702 FloatSqrtOp -> FSLIT("sqrt")
703 FloatSinOp -> FSLIT("sin")
704 FloatCosOp -> FSLIT("cos")
705 FloatTanOp -> FSLIT("tan")
706 FloatAsinOp -> FSLIT("asin")
707 FloatAcosOp -> FSLIT("acos")
708 FloatAtanOp -> FSLIT("atan")
709 FloatSinhOp -> FSLIT("sinh")
710 FloatCoshOp -> FSLIT("cosh")
711 FloatTanhOp -> FSLIT("tanh")
712 DoubleExpOp -> FSLIT("exp")
713 DoubleLogOp -> FSLIT("log")
714 DoubleSqrtOp -> FSLIT("sqrt")
715 DoubleSinOp -> FSLIT("sin")
716 DoubleCosOp -> FSLIT("cos")
717 DoubleTanOp -> FSLIT("tan")
718 DoubleAsinOp -> FSLIT("asin")
719 DoubleAcosOp -> FSLIT("acos")
720 DoubleAtanOp -> FSLIT("atan")
721 DoubleSinhOp -> FSLIT("sinh")
722 DoubleCoshOp -> FSLIT("cosh")
723 DoubleTanhOp -> FSLIT("tanh")
725 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
727 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
729 CharGtOp -> trivialCode (CMP LTT) y x
730 CharGeOp -> trivialCode (CMP LE) y x
731 CharEqOp -> trivialCode (CMP EQQ) x y
732 CharNeOp -> int_NE_code x y
733 CharLtOp -> trivialCode (CMP LTT) x y
734 CharLeOp -> trivialCode (CMP LE) x y
736 IntGtOp -> trivialCode (CMP LTT) y x
737 IntGeOp -> trivialCode (CMP LE) y x
738 IntEqOp -> trivialCode (CMP EQQ) x y
739 IntNeOp -> int_NE_code x y
740 IntLtOp -> trivialCode (CMP LTT) x y
741 IntLeOp -> trivialCode (CMP LE) x y
743 WordGtOp -> trivialCode (CMP ULT) y x
744 WordGeOp -> trivialCode (CMP ULE) x y
745 WordEqOp -> trivialCode (CMP EQQ) x y
746 WordNeOp -> int_NE_code x y
747 WordLtOp -> trivialCode (CMP ULT) x y
748 WordLeOp -> trivialCode (CMP ULE) x y
750 AddrGtOp -> trivialCode (CMP ULT) y x
751 AddrGeOp -> trivialCode (CMP ULE) y x
752 AddrEqOp -> trivialCode (CMP EQQ) x y
753 AddrNeOp -> int_NE_code x y
754 AddrLtOp -> trivialCode (CMP ULT) x y
755 AddrLeOp -> trivialCode (CMP ULE) x y
757 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
758 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
759 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
760 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
761 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
762 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
764 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
765 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
766 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
767 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
768 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
769 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
771 IntAddOp -> trivialCode (ADD Q False) x y
772 IntSubOp -> trivialCode (SUB Q False) x y
773 IntMulOp -> trivialCode (MUL Q False) x y
774 IntQuotOp -> trivialCode (DIV Q False) x y
775 IntRemOp -> trivialCode (REM Q False) x y
777 WordAddOp -> trivialCode (ADD Q False) x y
778 WordSubOp -> trivialCode (SUB Q False) x y
779 WordMulOp -> trivialCode (MUL Q False) x y
780 WordQuotOp -> trivialCode (DIV Q True) x y
781 WordRemOp -> trivialCode (REM Q True) x y
783 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
784 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
785 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
786 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
788 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
789 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
790 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
791 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
793 AddrAddOp -> trivialCode (ADD Q False) x y
794 AddrSubOp -> trivialCode (SUB Q False) x y
795 AddrRemOp -> trivialCode (REM Q True) x y
797 AndOp -> trivialCode AND x y
798 OrOp -> trivialCode OR x y
799 XorOp -> trivialCode XOR x y
800 SllOp -> trivialCode SLL x y
801 SrlOp -> trivialCode SRL x y
803 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
804 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
805 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
807 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
808 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
810 {- ------------------------------------------------------------
811 Some bizarre special code for getting condition codes into
812 registers. Integer non-equality is a test for equality
813 followed by an XOR with 1. (Integer comparisons always set
814 the result register to 0 or 1.) Floating point comparisons of
815 any kind leave the result in a floating point register, so we
816 need to wrangle an integer register out of things.
818 int_NE_code :: StixTree -> StixTree -> NatM Register
821 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
822 getNewRegNCG IntRep `thenNat` \ tmp ->
824 code = registerCode register tmp
825 src = registerName register tmp
826 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
828 returnNat (Any IntRep code__2)
830 {- ------------------------------------------------------------
831 Comments for int_NE_code also apply to cmpF_code
834 :: (Reg -> Reg -> Reg -> Instr)
836 -> StixTree -> StixTree
839 cmpF_code instr cond x y
840 = trivialFCode pr instr x y `thenNat` \ register ->
841 getNewRegNCG DoubleRep `thenNat` \ tmp ->
842 getNatLabelNCG `thenNat` \ lbl ->
844 code = registerCode register tmp
845 result = registerName register tmp
847 code__2 dst = code . mkSeqInstrs [
848 OR zeroh (RIImm (ImmInt 1)) dst,
849 BF cond result (ImmCLbl lbl),
850 OR zeroh (RIReg zeroh) dst,
853 returnNat (Any IntRep code__2)
855 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
856 ------------------------------------------------------------
858 getRegister (StInd pk mem)
859 = getAmode mem `thenNat` \ amode ->
861 code = amodeCode amode
862 src = amodeAddr amode
863 size = primRepToSize pk
864 code__2 dst = code . mkSeqInstr (LD size dst src)
866 returnNat (Any pk code__2)
868 getRegister (StInt i)
871 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
873 returnNat (Any IntRep code)
876 code dst = mkSeqInstr (LDI Q dst src)
878 returnNat (Any IntRep code)
880 src = ImmInt (fromInteger i)
885 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
887 returnNat (Any PtrRep code)
890 imm__2 = case imm of Just x -> x
892 #endif /* alpha_TARGET_ARCH */
894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
898 getRegister (StFloat f)
899 = getNatLabelNCG `thenNat` \ lbl ->
900 let code dst = toOL [
905 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
908 returnNat (Any FloatRep code)
911 getRegister (StDouble d)
914 = let code dst = unitOL (GLDZ dst)
915 in returnNat (Any DoubleRep code)
918 = let code dst = unitOL (GLD1 dst)
919 in returnNat (Any DoubleRep code)
922 = getNatLabelNCG `thenNat` \ lbl ->
923 let code dst = toOL [
926 DATA DF [ImmDouble d],
928 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
931 returnNat (Any DoubleRep code)
934 getRegister (StMachOp mop [x]) -- unary MachOps
936 MO_NatS_Neg -> trivialUCode (NEGI L) x
937 MO_Nat_Not -> trivialUCode (NOT L) x
938 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
940 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
941 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
943 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
944 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
946 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
947 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
949 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
950 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
952 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
953 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
955 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
956 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
957 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
958 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
960 -- Conversions which are a nop on x86
961 MO_32U_to_NatS -> conversionNop IntRep x
962 MO_32S_to_NatS -> conversionNop IntRep x
963 MO_NatS_to_32U -> conversionNop WordRep x
964 MO_32U_to_NatU -> conversionNop WordRep x
966 MO_NatU_to_NatS -> conversionNop IntRep x
967 MO_NatS_to_NatU -> conversionNop WordRep x
968 MO_NatP_to_NatU -> conversionNop WordRep x
969 MO_NatU_to_NatP -> conversionNop PtrRep x
970 MO_NatS_to_NatP -> conversionNop PtrRep x
971 MO_NatP_to_NatS -> conversionNop IntRep x
973 MO_Dbl_to_Flt -> conversionNop FloatRep x
974 MO_Flt_to_Dbl -> conversionNop DoubleRep x
976 -- sign-extending widenings
977 MO_8U_to_NatU -> integerExtend False 24 x
978 MO_8S_to_NatS -> integerExtend True 24 x
979 MO_16U_to_NatU -> integerExtend False 16 x
980 MO_16S_to_NatS -> integerExtend True 16 x
981 MO_8U_to_32U -> integerExtend False 24 x
985 (if is_float_op then demote else id)
986 (StCall (Left fn) CCallConv DoubleRep
987 [(if is_float_op then promote else id) x])
990 integerExtend signed nBits x
992 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
993 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
996 conversionNop new_rep expr
997 = getRegister expr `thenNat` \ e_code ->
998 returnNat (swizzleRegisterRep e_code new_rep)
1000 promote x = StMachOp MO_Flt_to_Dbl [x]
1001 demote x = StMachOp MO_Dbl_to_Flt [x]
1004 MO_Flt_Exp -> (True, FSLIT("exp"))
1005 MO_Flt_Log -> (True, FSLIT("log"))
1007 MO_Flt_Asin -> (True, FSLIT("asin"))
1008 MO_Flt_Acos -> (True, FSLIT("acos"))
1009 MO_Flt_Atan -> (True, FSLIT("atan"))
1011 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1012 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1013 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1015 MO_Dbl_Exp -> (False, FSLIT("exp"))
1016 MO_Dbl_Log -> (False, FSLIT("log"))
1018 MO_Dbl_Asin -> (False, FSLIT("asin"))
1019 MO_Dbl_Acos -> (False, FSLIT("acos"))
1020 MO_Dbl_Atan -> (False, FSLIT("atan"))
1022 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1023 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1024 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1026 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
1030 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
1032 MO_32U_Gt -> condIntReg GTT x y
1033 MO_32U_Ge -> condIntReg GE x y
1034 MO_32U_Eq -> condIntReg EQQ x y
1035 MO_32U_Ne -> condIntReg NE x y
1036 MO_32U_Lt -> condIntReg LTT x y
1037 MO_32U_Le -> condIntReg LE x y
1039 MO_Nat_Eq -> condIntReg EQQ x y
1040 MO_Nat_Ne -> condIntReg NE x y
1042 MO_NatS_Gt -> condIntReg GTT x y
1043 MO_NatS_Ge -> condIntReg GE x y
1044 MO_NatS_Lt -> condIntReg LTT x y
1045 MO_NatS_Le -> condIntReg LE x y
1047 MO_NatU_Gt -> condIntReg GU x y
1048 MO_NatU_Ge -> condIntReg GEU x y
1049 MO_NatU_Lt -> condIntReg LU x y
1050 MO_NatU_Le -> condIntReg LEU x y
1052 MO_Flt_Gt -> condFltReg GTT x y
1053 MO_Flt_Ge -> condFltReg GE x y
1054 MO_Flt_Eq -> condFltReg EQQ x y
1055 MO_Flt_Ne -> condFltReg NE x y
1056 MO_Flt_Lt -> condFltReg LTT x y
1057 MO_Flt_Le -> condFltReg LE x y
1059 MO_Dbl_Gt -> condFltReg GTT x y
1060 MO_Dbl_Ge -> condFltReg GE x y
1061 MO_Dbl_Eq -> condFltReg EQQ x y
1062 MO_Dbl_Ne -> condFltReg NE x y
1063 MO_Dbl_Lt -> condFltReg LTT x y
1064 MO_Dbl_Le -> condFltReg LE x y
1066 MO_Nat_Add -> add_code L x y
1067 MO_Nat_Sub -> sub_code L x y
1068 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
1069 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
1070 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
1071 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
1072 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
1073 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
1074 MO_NatS_MulMayOflo -> imulMayOflo x y
1076 MO_Flt_Add -> trivialFCode FloatRep GADD x y
1077 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
1078 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
1079 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
1081 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
1082 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
1083 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
1084 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
1086 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
1087 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
1088 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1090 {- Shift ops on x86s have constraints on their source, it
1091 either has to be Imm, CL or 1
1092 => trivialCode's is not restrictive enough (sigh.)
1094 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
1095 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1096 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1098 MO_Flt_Pwr -> getRegister (demote
1099 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1100 [promote x, promote y])
1102 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1104 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1106 promote x = StMachOp MO_Flt_to_Dbl [x]
1107 demote x = StMachOp MO_Dbl_to_Flt [x]
1109 --------------------
1110 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1112 = getNewRegNCG IntRep `thenNat` \ t1 ->
1113 getNewRegNCG IntRep `thenNat` \ t2 ->
1114 getNewRegNCG IntRep `thenNat` \ res_lo ->
1115 getNewRegNCG IntRep `thenNat` \ res_hi ->
1116 getRegister a1 `thenNat` \ reg1 ->
1117 getRegister a2 `thenNat` \ reg2 ->
1118 let code1 = registerCode reg1 t1
1119 code2 = registerCode reg2 t2
1120 src1 = registerName reg1 t1
1121 src2 = registerName reg2 t2
1122 code dst = code1 `appOL` code2 `appOL`
1124 MOV L (OpReg src1) (OpReg res_hi),
1125 MOV L (OpReg src2) (OpReg res_lo),
1126 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1127 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1128 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1129 MOV L (OpReg res_lo) (OpReg dst)
1130 -- dst==0 if high part == sign extended low part
1133 returnNat (Any IntRep code)
1135 --------------------
1136 shift_code :: (Imm -> Operand -> Instr)
1141 {- Case1: shift length as immediate -}
1142 -- Code is the same as the first eq. for trivialCode -- sigh.
1143 shift_code instr x y{-amount-}
1145 = getRegister x `thenNat` \ regx ->
1148 then registerCodeA regx dst `bind` \ code_x ->
1150 instr imm__2 (OpReg dst)
1151 else registerCodeF regx `bind` \ code_x ->
1152 registerNameF regx `bind` \ r_x ->
1154 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1155 instr imm__2 (OpReg dst)
1157 returnNat (Any IntRep mkcode)
1160 imm__2 = case imm of Just x -> x
1162 {- Case2: shift length is complex (non-immediate) -}
1163 -- Since ECX is always used as a spill temporary, we can't
1164 -- use it here to do non-immediate shifts. No big deal --
1165 -- they are only very rare, and we can use an equivalent
1166 -- test-and-jump sequence which doesn't use ECX.
1167 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1168 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1169 shift_code instr x y{-amount-}
1170 = getRegister x `thenNat` \ register1 ->
1171 getRegister y `thenNat` \ register2 ->
1172 getNatLabelNCG `thenNat` \ lbl_test3 ->
1173 getNatLabelNCG `thenNat` \ lbl_test2 ->
1174 getNatLabelNCG `thenNat` \ lbl_test1 ->
1175 getNatLabelNCG `thenNat` \ lbl_test0 ->
1176 getNatLabelNCG `thenNat` \ lbl_after ->
1177 getNewRegNCG IntRep `thenNat` \ tmp ->
1179 = let src_val = registerName register1 dst
1180 code_val = registerCode register1 dst
1181 src_amt = registerName register2 tmp
1182 code_amt = registerCode register2 tmp
1187 MOV L (OpReg src_amt) r_tmp `appOL`
1189 MOV L (OpReg src_val) r_dst `appOL`
1191 COMMENT (mkFastString "begin shift sequence"),
1192 MOV L (OpReg src_val) r_dst,
1193 MOV L (OpReg src_amt) r_tmp,
1195 BT L (ImmInt 4) r_tmp,
1197 instr (ImmInt 16) r_dst,
1200 BT L (ImmInt 3) r_tmp,
1202 instr (ImmInt 8) r_dst,
1205 BT L (ImmInt 2) r_tmp,
1207 instr (ImmInt 4) r_dst,
1210 BT L (ImmInt 1) r_tmp,
1212 instr (ImmInt 2) r_dst,
1215 BT L (ImmInt 0) r_tmp,
1217 instr (ImmInt 1) r_dst,
1220 COMMENT (mkFastString "end shift sequence")
1223 returnNat (Any IntRep code__2)
1225 --------------------
1226 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1228 add_code sz x (StInt y)
1229 = getRegister x `thenNat` \ register ->
1230 getNewRegNCG IntRep `thenNat` \ tmp ->
1232 code = registerCode register tmp
1233 src1 = registerName register tmp
1234 src2 = ImmInt (fromInteger y)
1237 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1240 returnNat (Any IntRep code__2)
1242 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1244 --------------------
1245 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1247 sub_code sz x (StInt y)
1248 = getRegister x `thenNat` \ register ->
1249 getNewRegNCG IntRep `thenNat` \ tmp ->
1251 code = registerCode register tmp
1252 src1 = registerName register tmp
1253 src2 = ImmInt (-(fromInteger y))
1256 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1259 returnNat (Any IntRep code__2)
1261 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1263 getRegister (StInd pk mem)
1264 | not (is64BitRep pk)
1265 = getAmode mem `thenNat` \ amode ->
1267 code = amodeCode amode
1268 src = amodeAddr amode
1269 size = primRepToSize pk
1270 code__2 dst = code `snocOL`
1271 if pk == DoubleRep || pk == FloatRep
1272 then GLD size src dst
1280 (OpAddr src) (OpReg dst)
1282 returnNat (Any pk code__2)
1284 getRegister (StInt i)
1286 src = ImmInt (fromInteger i)
1289 = unitOL (XOR L (OpReg dst) (OpReg dst))
1291 = unitOL (MOV L (OpImm src) (OpReg dst))
1293 returnNat (Any IntRep code)
1297 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1299 returnNat (Any PtrRep code)
1301 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1304 imm__2 = case imm of Just x -> x
1306 #endif /* i386_TARGET_ARCH */
1308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1310 #if sparc_TARGET_ARCH
1312 getRegister (StFloat d)
1313 = getNatLabelNCG `thenNat` \ lbl ->
1314 getNewRegNCG PtrRep `thenNat` \ tmp ->
1315 let code dst = toOL [
1316 SEGMENT DataSegment,
1318 DATA F [ImmFloat d],
1319 SEGMENT TextSegment,
1320 SETHI (HI (ImmCLbl lbl)) tmp,
1321 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1323 returnNat (Any FloatRep code)
1325 getRegister (StDouble d)
1326 = getNatLabelNCG `thenNat` \ lbl ->
1327 getNewRegNCG PtrRep `thenNat` \ tmp ->
1328 let code dst = toOL [
1329 SEGMENT DataSegment,
1331 DATA DF [ImmDouble d],
1332 SEGMENT TextSegment,
1333 SETHI (HI (ImmCLbl lbl)) tmp,
1334 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1336 returnNat (Any DoubleRep code)
1339 getRegister (StMachOp mop [x]) -- unary PrimOps
1341 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1342 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1343 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1345 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1346 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1348 MO_Dbl_to_Flt -> coerceDbl2Flt x
1349 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1351 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1352 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1353 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1354 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1356 -- Conversions which are a nop on sparc
1357 MO_32U_to_NatS -> conversionNop IntRep x
1358 MO_32S_to_NatS -> conversionNop IntRep x
1359 MO_NatS_to_32U -> conversionNop WordRep x
1360 MO_32U_to_NatU -> conversionNop WordRep x
1362 MO_NatU_to_NatS -> conversionNop IntRep x
1363 MO_NatS_to_NatU -> conversionNop WordRep x
1364 MO_NatP_to_NatU -> conversionNop WordRep x
1365 MO_NatU_to_NatP -> conversionNop PtrRep x
1366 MO_NatS_to_NatP -> conversionNop PtrRep x
1367 MO_NatP_to_NatS -> conversionNop IntRep x
1369 -- sign-extending widenings
1370 MO_8U_to_32U -> integerExtend False 24 x
1371 MO_8U_to_NatU -> integerExtend False 24 x
1372 MO_8S_to_NatS -> integerExtend True 24 x
1373 MO_16U_to_NatU -> integerExtend False 16 x
1374 MO_16S_to_NatS -> integerExtend True 16 x
1377 let fixed_x = if is_float_op -- promote to double
1378 then StMachOp MO_Flt_to_Dbl [x]
1381 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1383 integerExtend signed nBits x
1385 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1386 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1388 conversionNop new_rep expr
1389 = getRegister expr `thenNat` \ e_code ->
1390 returnNat (swizzleRegisterRep e_code new_rep)
1394 MO_Flt_Exp -> (True, FSLIT("exp"))
1395 MO_Flt_Log -> (True, FSLIT("log"))
1396 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1398 MO_Flt_Sin -> (True, FSLIT("sin"))
1399 MO_Flt_Cos -> (True, FSLIT("cos"))
1400 MO_Flt_Tan -> (True, FSLIT("tan"))
1402 MO_Flt_Asin -> (True, FSLIT("asin"))
1403 MO_Flt_Acos -> (True, FSLIT("acos"))
1404 MO_Flt_Atan -> (True, FSLIT("atan"))
1406 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1407 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1408 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1410 MO_Dbl_Exp -> (False, FSLIT("exp"))
1411 MO_Dbl_Log -> (False, FSLIT("log"))
1412 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1414 MO_Dbl_Sin -> (False, FSLIT("sin"))
1415 MO_Dbl_Cos -> (False, FSLIT("cos"))
1416 MO_Dbl_Tan -> (False, FSLIT("tan"))
1418 MO_Dbl_Asin -> (False, FSLIT("asin"))
1419 MO_Dbl_Acos -> (False, FSLIT("acos"))
1420 MO_Dbl_Atan -> (False, FSLIT("atan"))
1422 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1423 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1424 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1426 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1430 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1432 MO_32U_Gt -> condIntReg GTT x y
1433 MO_32U_Ge -> condIntReg GE x y
1434 MO_32U_Eq -> condIntReg EQQ x y
1435 MO_32U_Ne -> condIntReg NE x y
1436 MO_32U_Lt -> condIntReg LTT x y
1437 MO_32U_Le -> condIntReg LE x y
1439 MO_Nat_Eq -> condIntReg EQQ x y
1440 MO_Nat_Ne -> condIntReg NE x y
1442 MO_NatS_Gt -> condIntReg GTT x y
1443 MO_NatS_Ge -> condIntReg GE x y
1444 MO_NatS_Lt -> condIntReg LTT x y
1445 MO_NatS_Le -> condIntReg LE x y
1447 MO_NatU_Gt -> condIntReg GU x y
1448 MO_NatU_Ge -> condIntReg GEU x y
1449 MO_NatU_Lt -> condIntReg LU x y
1450 MO_NatU_Le -> condIntReg LEU x y
1452 MO_Flt_Gt -> condFltReg GTT x y
1453 MO_Flt_Ge -> condFltReg GE x y
1454 MO_Flt_Eq -> condFltReg EQQ x y
1455 MO_Flt_Ne -> condFltReg NE x y
1456 MO_Flt_Lt -> condFltReg LTT x y
1457 MO_Flt_Le -> condFltReg LE x y
1459 MO_Dbl_Gt -> condFltReg GTT x y
1460 MO_Dbl_Ge -> condFltReg GE x y
1461 MO_Dbl_Eq -> condFltReg EQQ x y
1462 MO_Dbl_Ne -> condFltReg NE x y
1463 MO_Dbl_Lt -> condFltReg LTT x y
1464 MO_Dbl_Le -> condFltReg LE x y
1466 MO_Nat_Add -> trivialCode (ADD False False) x y
1467 MO_Nat_Sub -> trivialCode (SUB False False) x y
1469 MO_NatS_Mul -> trivialCode (SMUL False) x y
1470 MO_NatU_Mul -> trivialCode (UMUL False) x y
1471 MO_NatS_MulMayOflo -> imulMayOflo x y
1473 -- ToDo: teach about V8+ SPARC div instructions
1474 MO_NatS_Quot -> idiv FSLIT(".div") x y
1475 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1476 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1477 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1479 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1480 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1481 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1482 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1484 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1485 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1486 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1487 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1489 MO_Nat_And -> trivialCode (AND False) x y
1490 MO_Nat_Or -> trivialCode (OR False) x y
1491 MO_Nat_Xor -> trivialCode (XOR False) x y
1493 MO_Nat_Shl -> trivialCode SLL x y
1494 MO_Nat_Shr -> trivialCode SRL x y
1495 MO_Nat_Sar -> trivialCode SRA x y
1497 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1498 [promote x, promote y])
1499 where promote x = StMachOp MO_Flt_to_Dbl [x]
1500 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1503 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1505 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1507 --------------------
1508 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1510 = getNewRegNCG IntRep `thenNat` \ t1 ->
1511 getNewRegNCG IntRep `thenNat` \ t2 ->
1512 getNewRegNCG IntRep `thenNat` \ res_lo ->
1513 getNewRegNCG IntRep `thenNat` \ res_hi ->
1514 getRegister a1 `thenNat` \ reg1 ->
1515 getRegister a2 `thenNat` \ reg2 ->
1516 let code1 = registerCode reg1 t1
1517 code2 = registerCode reg2 t2
1518 src1 = registerName reg1 t1
1519 src2 = registerName reg2 t2
1520 code dst = code1 `appOL` code2 `appOL`
1522 SMUL False src1 (RIReg src2) res_lo,
1524 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1525 SUB False False res_lo (RIReg res_hi) dst
1528 returnNat (Any IntRep code)
1530 getRegister (StInd pk mem)
1531 = getAmode mem `thenNat` \ amode ->
1533 code = amodeCode amode
1534 src = amodeAddr amode
1535 size = primRepToSize pk
1536 code__2 dst = code `snocOL` LD size src dst
1538 returnNat (Any pk code__2)
1540 getRegister (StInt i)
1543 src = ImmInt (fromInteger i)
1544 code dst = unitOL (OR False g0 (RIImm src) dst)
1546 returnNat (Any IntRep code)
1552 SETHI (HI imm__2) dst,
1553 OR False dst (RIImm (LO imm__2)) dst]
1555 returnNat (Any PtrRep code)
1557 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1560 imm__2 = case imm of Just x -> x
1562 #endif /* sparc_TARGET_ARCH */
1564 #if powerpc_TARGET_ARCH
1565 getRegister (StMachOp mop [x]) -- unary MachOps
1567 MO_NatS_Neg -> trivialUCode NEG x
1568 MO_Nat_Not -> trivialUCode NOT x
1569 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1571 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1572 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1573 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1574 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1576 -- Conversions which are a nop on PPC
1577 MO_NatS_to_32U -> conversionNop WordRep x
1578 MO_32U_to_NatS -> conversionNop IntRep x
1579 MO_32U_to_NatU -> conversionNop WordRep x
1581 MO_NatU_to_NatS -> conversionNop IntRep x
1582 MO_NatS_to_NatU -> conversionNop WordRep x
1583 MO_NatP_to_NatU -> conversionNop WordRep x
1584 MO_NatU_to_NatP -> conversionNop PtrRep x
1585 MO_NatS_to_NatP -> conversionNop PtrRep x
1586 MO_NatP_to_NatS -> conversionNop IntRep x
1588 MO_Dbl_to_Flt -> conversionNop FloatRep x
1589 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1591 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1592 MO_8U_to_NatU -> integerExtend False 24 x
1593 MO_8S_to_NatS -> integerExtend True 24 x
1594 MO_16U_to_NatU -> integerExtend False 16 x
1595 MO_16S_to_NatS -> integerExtend True 16 x
1596 MO_8U_to_32U -> integerExtend False 24 x
1598 MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
1599 MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
1601 other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
1603 integerExtend signed nBits x
1605 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1606 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1608 conversionNop new_rep expr
1609 = getRegister expr `thenNat` \ e_code ->
1610 returnNat (swizzleRegisterRep e_code new_rep)
1614 MO_Flt_Exp -> (True, FSLIT("exp"))
1615 MO_Flt_Log -> (True, FSLIT("log"))
1616 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1618 MO_Flt_Sin -> (True, FSLIT("sin"))
1619 MO_Flt_Cos -> (True, FSLIT("cos"))
1620 MO_Flt_Tan -> (True, FSLIT("tan"))
1622 MO_Flt_Asin -> (True, FSLIT("asin"))
1623 MO_Flt_Acos -> (True, FSLIT("acos"))
1624 MO_Flt_Atan -> (True, FSLIT("atan"))
1626 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1627 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1628 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1630 MO_Dbl_Exp -> (False, FSLIT("exp"))
1631 MO_Dbl_Log -> (False, FSLIT("log"))
1632 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1634 MO_Dbl_Sin -> (False, FSLIT("sin"))
1635 MO_Dbl_Cos -> (False, FSLIT("cos"))
1636 MO_Dbl_Tan -> (False, FSLIT("tan"))
1638 MO_Dbl_Asin -> (False, FSLIT("asin"))
1639 MO_Dbl_Acos -> (False, FSLIT("acos"))
1640 MO_Dbl_Atan -> (False, FSLIT("atan"))
1642 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1643 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1644 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1646 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1650 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1652 MO_32U_Gt -> condIntReg GTT x y
1653 MO_32U_Ge -> condIntReg GE x y
1654 MO_32U_Eq -> condIntReg EQQ x y
1655 MO_32U_Ne -> condIntReg NE x y
1656 MO_32U_Lt -> condIntReg LTT x y
1657 MO_32U_Le -> condIntReg LE x y
1659 MO_Nat_Eq -> condIntReg EQQ x y
1660 MO_Nat_Ne -> condIntReg NE x y
1662 MO_NatS_Gt -> condIntReg GTT x y
1663 MO_NatS_Ge -> condIntReg GE x y
1664 MO_NatS_Lt -> condIntReg LTT x y
1665 MO_NatS_Le -> condIntReg LE x y
1667 MO_NatU_Gt -> condIntReg GU x y
1668 MO_NatU_Ge -> condIntReg GEU x y
1669 MO_NatU_Lt -> condIntReg LU x y
1670 MO_NatU_Le -> condIntReg LEU x y
1672 MO_Flt_Gt -> condFltReg GTT x y
1673 MO_Flt_Ge -> condFltReg GE x y
1674 MO_Flt_Eq -> condFltReg EQQ x y
1675 MO_Flt_Ne -> condFltReg NE x y
1676 MO_Flt_Lt -> condFltReg LTT x y
1677 MO_Flt_Le -> condFltReg LE x y
1679 MO_Dbl_Gt -> condFltReg GTT x y
1680 MO_Dbl_Ge -> condFltReg GE x y
1681 MO_Dbl_Eq -> condFltReg EQQ x y
1682 MO_Dbl_Ne -> condFltReg NE x y
1683 MO_Dbl_Lt -> condFltReg LTT x y
1684 MO_Dbl_Le -> condFltReg LE x y
1686 MO_Nat_Add -> trivialCode ADD x y
1687 MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
1688 case y of -- subfi ('substract from' with immediate) doesn't exist
1689 StInt imm -> if fits16Bits imm && imm /= (-32768)
1690 then Just $ trivialCode ADD x (StInt (-imm))
1694 MO_NatS_Mul -> trivialCode MULLW x y
1695 MO_NatU_Mul -> trivialCode MULLW x y
1696 -- MO_NatS_MulMayOflo ->
1698 MO_NatS_Quot -> trivialCode2 DIVW x y
1699 MO_NatU_Quot -> trivialCode2 DIVWU x y
1701 MO_NatS_Rem -> remainderCode DIVW x y
1702 MO_NatU_Rem -> remainderCode DIVWU x y
1704 MO_Nat_And -> trivialCode AND x y
1705 MO_Nat_Or -> trivialCode OR x y
1706 MO_Nat_Xor -> trivialCode XOR x y
1708 MO_Nat_Shl -> trivialCode SLW x y
1709 MO_Nat_Shr -> trivialCode SRW x y
1710 MO_Nat_Sar -> trivialCode SRAW x y
1712 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1713 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1714 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1715 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1717 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1718 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1719 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1720 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1722 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1724 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1727 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1729 getRegister (StInd pk mem)
1730 = getAmode mem `thenNat` \ amode ->
1732 code = amodeCode amode
1733 src = amodeAddr amode
1734 size = primRepToSize pk
1735 code__2 dst = code `snocOL` LD size dst src
1737 returnNat (Any pk code__2)
1739 getRegister (StInt i)
1742 src = ImmInt (fromInteger i)
1743 code dst = unitOL (LI dst src)
1745 returnNat (Any IntRep code)
1747 getRegister (StFloat d)
1748 = getNatLabelNCG `thenNat` \ lbl ->
1749 getNewRegNCG PtrRep `thenNat` \ tmp ->
1750 let code dst = toOL [
1751 SEGMENT RoDataSegment,
1753 DATA F [ImmFloat d],
1754 SEGMENT TextSegment,
1755 LIS tmp (HA (ImmCLbl lbl)),
1756 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1758 returnNat (Any FloatRep code)
1760 getRegister (StDouble d)
1761 = getNatLabelNCG `thenNat` \ lbl ->
1762 getNewRegNCG PtrRep `thenNat` \ tmp ->
1763 let code dst = toOL [
1764 SEGMENT RoDataSegment,
1766 DATA DF [ImmDouble d],
1767 SEGMENT TextSegment,
1768 LIS tmp (HA (ImmCLbl lbl)),
1769 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1771 returnNat (Any DoubleRep code)
1777 LIS dst (HI imm__2),
1778 OR dst dst (RIImm (LO imm__2))]
1780 returnNat (Any PtrRep code)
1782 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1785 imm__2 = case imm of Just x -> x
1786 #endif /* powerpc_TARGET_ARCH */
1788 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1794 %************************************************************************
1796 \subsection{The @Amode@ type}
1798 %************************************************************************
1800 @Amode@s: Memory addressing modes passed up the tree.
1802 data Amode = Amode MachRegsAddr InstrBlock
1804 amodeAddr (Amode addr _) = addr
1805 amodeCode (Amode _ code) = code
1808 Now, given a tree (the argument to an StInd) that references memory,
1809 produce a suitable addressing mode.
1811 A Rule of the Game (tm) for Amodes: use of the addr bit must
1812 immediately follow use of the code part, since the code part puts
1813 values in registers which the addr then refers to. So you can't put
1814 anything in between, lest it overwrite some of those registers. If
1815 you need to do some other computation between the code part and use of
1816 the addr bit, first store the effective address from the amode in a
1817 temporary, then do the other computation, and then use the temporary:
1821 ... other computation ...
1825 getAmode :: StixExpr -> NatM Amode
1827 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1829 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1831 #if alpha_TARGET_ARCH
1833 getAmode (StPrim IntSubOp [x, StInt i])
1834 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1835 getRegister x `thenNat` \ register ->
1837 code = registerCode register tmp
1838 reg = registerName register tmp
1839 off = ImmInt (-(fromInteger i))
1841 returnNat (Amode (AddrRegImm reg off) code)
1843 getAmode (StPrim IntAddOp [x, StInt i])
1844 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1845 getRegister x `thenNat` \ register ->
1847 code = registerCode register tmp
1848 reg = registerName register tmp
1849 off = ImmInt (fromInteger i)
1851 returnNat (Amode (AddrRegImm reg off) code)
1855 = returnNat (Amode (AddrImm imm__2) id)
1858 imm__2 = case imm of Just x -> x
1861 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1862 getRegister other `thenNat` \ register ->
1864 code = registerCode register tmp
1865 reg = registerName register tmp
1867 returnNat (Amode (AddrReg reg) code)
1869 #endif /* alpha_TARGET_ARCH */
1871 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1873 #if i386_TARGET_ARCH
1875 -- This is all just ridiculous, since it carefully undoes
1876 -- what mangleIndexTree has just done.
1877 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1878 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1879 getRegister x `thenNat` \ register ->
1881 code = registerCode register tmp
1882 reg = registerName register tmp
1883 off = ImmInt (-(fromInteger i))
1885 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1887 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1889 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1892 imm__2 = case imm of Just x -> x
1894 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1895 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1896 getRegister x `thenNat` \ register ->
1898 code = registerCode register tmp
1899 reg = registerName register tmp
1900 off = ImmInt (fromInteger i)
1902 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1904 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1905 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1906 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1907 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1908 getRegister x `thenNat` \ register1 ->
1909 getRegister y `thenNat` \ register2 ->
1911 code1 = registerCode register1 tmp1
1912 reg1 = registerName register1 tmp1
1913 code2 = registerCode register2 tmp2
1914 reg2 = registerName register2 tmp2
1915 code__2 = code1 `appOL` code2
1916 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1918 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1923 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1926 imm__2 = case imm of Just x -> x
1929 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1930 getRegister other `thenNat` \ register ->
1932 code = registerCode register tmp
1933 reg = registerName register tmp
1935 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1937 #endif /* i386_TARGET_ARCH */
1939 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1941 #if sparc_TARGET_ARCH
1943 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1945 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1946 getRegister x `thenNat` \ register ->
1948 code = registerCode register tmp
1949 reg = registerName register tmp
1950 off = ImmInt (-(fromInteger i))
1952 returnNat (Amode (AddrRegImm reg off) code)
1955 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1957 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1958 getRegister x `thenNat` \ register ->
1960 code = registerCode register tmp
1961 reg = registerName register tmp
1962 off = ImmInt (fromInteger i)
1964 returnNat (Amode (AddrRegImm reg off) code)
1966 getAmode (StMachOp MO_Nat_Add [x, y])
1967 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1968 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1969 getRegister x `thenNat` \ register1 ->
1970 getRegister y `thenNat` \ register2 ->
1972 code1 = registerCode register1 tmp1
1973 reg1 = registerName register1 tmp1
1974 code2 = registerCode register2 tmp2
1975 reg2 = registerName register2 tmp2
1976 code__2 = code1 `appOL` code2
1978 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1982 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1984 code = unitOL (SETHI (HI imm__2) tmp)
1986 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1989 imm__2 = case imm of Just x -> x
1992 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1993 getRegister other `thenNat` \ register ->
1995 code = registerCode register tmp
1996 reg = registerName register tmp
1999 returnNat (Amode (AddrRegImm reg off) code)
2001 #endif /* sparc_TARGET_ARCH */
2003 #ifdef powerpc_TARGET_ARCH
2004 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
2006 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2007 getRegister x `thenNat` \ register ->
2009 code = registerCode register tmp
2010 reg = registerName register tmp
2011 off = ImmInt (-(fromInteger i))
2013 returnNat (Amode (AddrRegImm reg off) code)
2016 getAmode (StMachOp MO_Nat_Add [x, StInt i])
2018 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2019 getRegister x `thenNat` \ register ->
2021 code = registerCode register tmp
2022 reg = registerName register tmp
2023 off = ImmInt (fromInteger i)
2025 returnNat (Amode (AddrRegImm reg off) code)
2029 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2031 code = unitOL (LIS tmp (HA imm__2))
2033 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
2036 imm__2 = case imm of Just x -> x
2039 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2040 getRegister other `thenNat` \ register ->
2042 code = registerCode register tmp
2043 reg = registerName register tmp
2046 returnNat (Amode (AddrRegImm reg off) code)
2047 #endif /* powerpc_TARGET_ARCH */
2049 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2052 %************************************************************************
2054 \subsection{The @CondCode@ type}
2056 %************************************************************************
2058 Condition codes passed up the tree.
2060 data CondCode = CondCode Bool Cond InstrBlock
2062 condName (CondCode _ cond _) = cond
2063 condFloat (CondCode is_float _ _) = is_float
2064 condCode (CondCode _ _ code) = code
2067 Set up a condition code for a conditional branch.
2070 getCondCode :: StixExpr -> NatM CondCode
2072 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2074 #if alpha_TARGET_ARCH
2075 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2076 #endif /* alpha_TARGET_ARCH */
2078 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2080 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2081 -- yes, they really do seem to want exactly the same!
2083 getCondCode (StMachOp mop [x, y])
2085 MO_32U_Gt -> condIntCode GTT x y
2086 MO_32U_Ge -> condIntCode GE x y
2087 MO_32U_Eq -> condIntCode EQQ x y
2088 MO_32U_Ne -> condIntCode NE x y
2089 MO_32U_Lt -> condIntCode LTT x y
2090 MO_32U_Le -> condIntCode LE x y
2092 MO_Nat_Eq -> condIntCode EQQ x y
2093 MO_Nat_Ne -> condIntCode NE x y
2095 MO_NatS_Gt -> condIntCode GTT x y
2096 MO_NatS_Ge -> condIntCode GE x y
2097 MO_NatS_Lt -> condIntCode LTT x y
2098 MO_NatS_Le -> condIntCode LE x y
2100 MO_NatU_Gt -> condIntCode GU x y
2101 MO_NatU_Ge -> condIntCode GEU x y
2102 MO_NatU_Lt -> condIntCode LU x y
2103 MO_NatU_Le -> condIntCode LEU x y
2105 MO_Flt_Gt -> condFltCode GTT x y
2106 MO_Flt_Ge -> condFltCode GE x y
2107 MO_Flt_Eq -> condFltCode EQQ x y
2108 MO_Flt_Ne -> condFltCode NE x y
2109 MO_Flt_Lt -> condFltCode LTT x y
2110 MO_Flt_Le -> condFltCode LE x y
2112 MO_Dbl_Gt -> condFltCode GTT x y
2113 MO_Dbl_Ge -> condFltCode GE x y
2114 MO_Dbl_Eq -> condFltCode EQQ x y
2115 MO_Dbl_Ne -> condFltCode NE x y
2116 MO_Dbl_Lt -> condFltCode LTT x y
2117 MO_Dbl_Le -> condFltCode LE x y
2119 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2121 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2123 #endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
2126 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2131 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2132 passed back up the tree.
2135 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2137 #if alpha_TARGET_ARCH
2138 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2139 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2140 #endif /* alpha_TARGET_ARCH */
2142 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2143 #if i386_TARGET_ARCH
2145 -- memory vs immediate
2146 condIntCode cond (StInd pk x) y
2147 | Just i <- maybeImm y
2148 = getAmode x `thenNat` \ amode ->
2150 code1 = amodeCode amode
2151 x__2 = amodeAddr amode
2152 sz = primRepToSize pk
2153 code__2 = code1 `snocOL`
2154 CMP sz (OpImm i) (OpAddr x__2)
2156 returnNat (CondCode False cond code__2)
2159 condIntCode cond x (StInt 0)
2160 = getRegister x `thenNat` \ register1 ->
2161 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2163 code1 = registerCode register1 tmp1
2164 src1 = registerName register1 tmp1
2165 code__2 = code1 `snocOL`
2166 TEST L (OpReg src1) (OpReg src1)
2168 returnNat (CondCode False cond code__2)
2170 -- anything vs immediate
2171 condIntCode cond x y
2172 | Just i <- maybeImm y
2173 = getRegister x `thenNat` \ register1 ->
2174 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2176 code1 = registerCode register1 tmp1
2177 src1 = registerName register1 tmp1
2178 code__2 = code1 `snocOL`
2179 CMP L (OpImm i) (OpReg src1)
2181 returnNat (CondCode False cond code__2)
2183 -- memory vs anything
2184 condIntCode cond (StInd pk x) y
2185 = getAmode x `thenNat` \ amode_x ->
2186 getRegister y `thenNat` \ reg_y ->
2187 getNewRegNCG IntRep `thenNat` \ tmp ->
2189 c_x = amodeCode amode_x
2190 am_x = amodeAddr amode_x
2191 c_y = registerCode reg_y tmp
2192 r_y = registerName reg_y tmp
2193 sz = primRepToSize pk
2195 -- optimisation: if there's no code for x, just an amode,
2196 -- use whatever reg y winds up in. Assumes that c_y doesn't
2197 -- clobber any regs in the amode am_x, which I'm not sure is
2198 -- justified. The otherwise clause makes the same assumption.
2199 code__2 | isNilOL c_x
2201 CMP sz (OpReg r_y) (OpAddr am_x)
2205 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2207 CMP sz (OpReg tmp) (OpAddr am_x)
2209 returnNat (CondCode False cond code__2)
2211 -- anything vs memory
2213 condIntCode cond y (StInd pk x)
2214 = getAmode x `thenNat` \ amode_x ->
2215 getRegister y `thenNat` \ reg_y ->
2216 getNewRegNCG IntRep `thenNat` \ tmp ->
2218 c_x = amodeCode amode_x
2219 am_x = amodeAddr amode_x
2220 c_y = registerCode reg_y tmp
2221 r_y = registerName reg_y tmp
2222 sz = primRepToSize pk
2223 -- same optimisation and nagging doubts as previous clause
2224 code__2 | isNilOL c_x
2226 CMP sz (OpAddr am_x) (OpReg r_y)
2230 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2232 CMP sz (OpAddr am_x) (OpReg tmp)
2234 returnNat (CondCode False cond code__2)
2236 -- anything vs anything
2237 condIntCode cond x y
2238 = getRegister x `thenNat` \ register1 ->
2239 getRegister y `thenNat` \ register2 ->
2240 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2241 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2243 code1 = registerCode register1 tmp1
2244 src1 = registerName register1 tmp1
2245 code2 = registerCode register2 tmp2
2246 src2 = registerName register2 tmp2
2247 code__2 = code1 `snocOL`
2248 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2250 CMP L (OpReg src2) (OpReg tmp1)
2252 returnNat (CondCode False cond code__2)
2255 condFltCode cond x y
2256 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2257 getRegister x `thenNat` \ register1 ->
2258 getRegister y `thenNat` \ register2 ->
2259 getNewRegNCG (registerRep register1)
2261 getNewRegNCG (registerRep register2)
2263 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2265 code1 = registerCode register1 tmp1
2266 src1 = registerName register1 tmp1
2268 code2 = registerCode register2 tmp2
2269 src2 = registerName register2 tmp2
2271 code__2 | isAny register1
2272 = code1 `appOL` -- result in tmp1
2278 GMOV src1 tmp1 `appOL`
2282 -- The GCMP insn does the test and sets the zero flag if comparable
2283 -- and true. Hence we always supply EQQ as the condition to test.
2284 returnNat (CondCode True EQQ code__2)
2286 #endif /* i386_TARGET_ARCH */
2288 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2290 #if sparc_TARGET_ARCH
2292 condIntCode cond x (StInt y)
2294 = getRegister x `thenNat` \ register ->
2295 getNewRegNCG IntRep `thenNat` \ tmp ->
2297 code = registerCode register tmp
2298 src1 = registerName register tmp
2299 src2 = ImmInt (fromInteger y)
2300 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2302 returnNat (CondCode False cond code__2)
2304 condIntCode cond x y
2305 = getRegister x `thenNat` \ register1 ->
2306 getRegister y `thenNat` \ register2 ->
2307 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2308 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2310 code1 = registerCode register1 tmp1
2311 src1 = registerName register1 tmp1
2312 code2 = registerCode register2 tmp2
2313 src2 = registerName register2 tmp2
2314 code__2 = code1 `appOL` code2 `snocOL`
2315 SUB False True src1 (RIReg src2) g0
2317 returnNat (CondCode False cond code__2)
2320 condFltCode cond x y
2321 = getRegister x `thenNat` \ register1 ->
2322 getRegister y `thenNat` \ register2 ->
2323 getNewRegNCG (registerRep register1)
2325 getNewRegNCG (registerRep register2)
2327 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2329 promote x = FxTOy F DF x tmp
2331 pk1 = registerRep register1
2332 code1 = registerCode register1 tmp1
2333 src1 = registerName register1 tmp1
2335 pk2 = registerRep register2
2336 code2 = registerCode register2 tmp2
2337 src2 = registerName register2 tmp2
2341 code1 `appOL` code2 `snocOL`
2342 FCMP True (primRepToSize pk1) src1 src2
2343 else if pk1 == FloatRep then
2344 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2345 FCMP True DF tmp src2
2347 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2348 FCMP True DF src1 tmp
2350 returnNat (CondCode True cond code__2)
2352 #endif /* sparc_TARGET_ARCH */
2354 #if powerpc_TARGET_ARCH
2356 condIntCode cond x (StInt y)
2358 = getRegister x `thenNat` \ register ->
2359 getNewRegNCG IntRep `thenNat` \ tmp ->
2361 code = registerCode register tmp
2362 src1 = registerName register tmp
2363 src2 = ImmInt (fromInteger y)
2364 code__2 = code `snocOL`
2365 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2367 returnNat (CondCode False cond code__2)
2369 condIntCode cond x y
2370 = getRegister x `thenNat` \ register1 ->
2371 getRegister y `thenNat` \ register2 ->
2372 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2373 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2375 code1 = registerCode register1 tmp1
2376 src1 = registerName register1 tmp1
2377 code2 = registerCode register2 tmp2
2378 src2 = registerName register2 tmp2
2379 code__2 = code1 `appOL` code2 `snocOL`
2380 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2382 returnNat (CondCode False cond code__2)
2384 condFltCode cond x y
2385 = getRegister x `thenNat` \ register1 ->
2386 getRegister y `thenNat` \ register2 ->
2387 getNewRegNCG (registerRep register1)
2389 getNewRegNCG (registerRep register2)
2392 code1 = registerCode register1 tmp1
2393 src1 = registerName register1 tmp1
2394 code2 = registerCode register2 tmp2
2395 src2 = registerName register2 tmp2
2396 code__2 = code1 `appOL` code2 `snocOL`
2399 returnNat (CondCode False cond code__2)
2401 #endif /* powerpc_TARGET_ARCH */
2404 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2407 %************************************************************************
2409 \subsection{Generating assignments}
2411 %************************************************************************
2413 Assignments are really at the heart of the whole code generation
2414 business. Almost all top-level nodes of any real importance are
2415 assignments, which correspond to loads, stores, or register transfers.
2416 If we're really lucky, some of the register transfers will go away,
2417 because we can use the destination register to complete the code
2418 generation for the right hand side. This only fails when the right
2419 hand side is forced into a fixed register (e.g. the result of a call).
2422 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2423 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2425 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2426 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2428 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2430 #if alpha_TARGET_ARCH
2432 assignIntCode pk (StInd _ dst) src
2433 = getNewRegNCG IntRep `thenNat` \ tmp ->
2434 getAmode dst `thenNat` \ amode ->
2435 getRegister src `thenNat` \ register ->
2437 code1 = amodeCode amode []
2438 dst__2 = amodeAddr amode
2439 code2 = registerCode register tmp []
2440 src__2 = registerName register tmp
2441 sz = primRepToSize pk
2442 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2446 assignIntCode pk dst src
2447 = getRegister dst `thenNat` \ register1 ->
2448 getRegister src `thenNat` \ register2 ->
2450 dst__2 = registerName register1 zeroh
2451 code = registerCode register2 dst__2
2452 src__2 = registerName register2 dst__2
2453 code__2 = if isFixed register2
2454 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2459 #endif /* alpha_TARGET_ARCH */
2461 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2463 #if i386_TARGET_ARCH
2465 -- non-FP assignment to memory
2466 assignMem_IntCode pk addr src
2467 = getAmode addr `thenNat` \ amode ->
2468 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2469 getNewRegNCG PtrRep `thenNat` \ tmp ->
2471 -- In general, if the address computation for dst may require
2472 -- some insns preceding the addressing mode itself. So there's
2473 -- no guarantee that the code for dst and the code for src won't
2474 -- write the same register. This means either the address or
2475 -- the value needs to be copied into a temporary. We detect the
2476 -- common case where the amode has no code, and elide the copy.
2477 codea = amodeCode amode
2478 dst__a = amodeAddr amode
2480 code | isNilOL codea
2482 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2485 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2487 MOV (primRepToSize pk) opsrc
2488 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2494 -> NatM (InstrBlock,Operand) -- code, operator
2497 | Just x <- maybeImm op
2498 = returnNat (nilOL, OpImm x)
2501 = getRegister op `thenNat` \ register ->
2502 getNewRegNCG (registerRep register)
2504 let code = registerCode register tmp
2505 reg = registerName register tmp
2507 returnNat (code, OpReg reg)
2509 -- Assign; dst is a reg, rhs is mem
2510 assignReg_IntCode pk reg (StInd pks src)
2511 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2512 getAmode src `thenNat` \ amode ->
2513 getRegisterReg reg `thenNat` \ reg_dst ->
2515 c_addr = amodeCode amode
2516 am_addr = amodeAddr amode
2517 r_dst = registerName reg_dst tmp
2518 szs = primRepToSize pks
2527 code = c_addr `snocOL`
2528 opc (OpAddr am_addr) (OpReg r_dst)
2532 -- dst is a reg, but src could be anything
2533 assignReg_IntCode pk reg src
2534 = getRegisterReg reg `thenNat` \ registerd ->
2535 getRegister src `thenNat` \ registers ->
2536 getNewRegNCG IntRep `thenNat` \ tmp ->
2538 r_dst = registerName registerd tmp
2539 r_src = registerName registers r_dst
2540 c_src = registerCode registers r_dst
2542 code = c_src `snocOL`
2543 MOV L (OpReg r_src) (OpReg r_dst)
2547 #endif /* i386_TARGET_ARCH */
2549 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2551 #if sparc_TARGET_ARCH
2553 assignMem_IntCode pk addr src
2554 = getNewRegNCG IntRep `thenNat` \ tmp ->
2555 getAmode addr `thenNat` \ amode ->
2556 getRegister src `thenNat` \ register ->
2558 code1 = amodeCode amode
2559 dst__2 = amodeAddr amode
2560 code2 = registerCode register tmp
2561 src__2 = registerName register tmp
2562 sz = primRepToSize pk
2563 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2567 assignReg_IntCode pk reg src
2568 = getRegister src `thenNat` \ register2 ->
2569 getRegisterReg reg `thenNat` \ register1 ->
2570 getNewRegNCG IntRep `thenNat` \ tmp ->
2572 dst__2 = registerName register1 tmp
2573 code = registerCode register2 dst__2
2574 src__2 = registerName register2 dst__2
2575 code__2 = if isFixed register2
2576 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2581 #endif /* sparc_TARGET_ARCH */
2583 #if powerpc_TARGET_ARCH
2585 assignMem_IntCode pk addr src
2586 = getNewRegNCG IntRep `thenNat` \ tmp ->
2587 getAmode addr `thenNat` \ amode ->
2588 getRegister src `thenNat` \ register ->
2590 code1 = amodeCode amode
2591 dst__2 = amodeAddr amode
2592 code2 = registerCode register tmp
2593 src__2 = registerName register tmp
2594 sz = primRepToSize pk
2595 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2599 assignReg_IntCode pk reg src
2600 = getRegister src `thenNat` \ register2 ->
2601 getRegisterReg reg `thenNat` \ register1 ->
2603 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2604 code = registerCode register2 dst__2
2605 src__2 = registerName register2 dst__2
2606 code__2 = if isFixed register2
2607 then code `snocOL` MR dst__2 src__2
2612 #endif /* powerpc_TARGET_ARCH */
2614 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2617 % --------------------------------
2618 Floating-point assignments:
2619 % --------------------------------
2622 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2623 #if alpha_TARGET_ARCH
2625 assignFltCode pk (StInd _ dst) src
2626 = getNewRegNCG pk `thenNat` \ tmp ->
2627 getAmode dst `thenNat` \ amode ->
2628 getRegister src `thenNat` \ register ->
2630 code1 = amodeCode amode []
2631 dst__2 = amodeAddr amode
2632 code2 = registerCode register tmp []
2633 src__2 = registerName register tmp
2634 sz = primRepToSize pk
2635 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2639 assignFltCode pk dst src
2640 = getRegister dst `thenNat` \ register1 ->
2641 getRegister src `thenNat` \ register2 ->
2643 dst__2 = registerName register1 zeroh
2644 code = registerCode register2 dst__2
2645 src__2 = registerName register2 dst__2
2646 code__2 = if isFixed register2
2647 then code . mkSeqInstr (FMOV src__2 dst__2)
2652 #endif /* alpha_TARGET_ARCH */
2654 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2656 #if i386_TARGET_ARCH
2658 -- Floating point assignment to memory
2659 assignMem_FltCode pk addr src
2660 = getRegister src `thenNat` \ reg_src ->
2661 getRegister addr `thenNat` \ reg_addr ->
2662 getNewRegNCG pk `thenNat` \ tmp_src ->
2663 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2664 let r_src = registerName reg_src tmp_src
2665 c_src = registerCode reg_src tmp_src
2666 r_addr = registerName reg_addr tmp_addr
2667 c_addr = registerCode reg_addr tmp_addr
2668 sz = primRepToSize pk
2670 code = c_src `appOL`
2671 -- no need to preserve r_src across the addr computation,
2672 -- since r_src must be a float reg
2673 -- whilst r_addr is an int reg
2676 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2680 -- Floating point assignment to a register/temporary
2681 assignReg_FltCode pk reg src
2682 = getRegisterReg reg `thenNat` \ reg_dst ->
2683 getRegister src `thenNat` \ reg_src ->
2684 getNewRegNCG pk `thenNat` \ tmp ->
2686 r_dst = registerName reg_dst tmp
2687 r_src = registerName reg_src r_dst
2688 c_src = registerCode reg_src r_dst
2690 code = if isFixed reg_src
2691 then c_src `snocOL` GMOV r_src r_dst
2697 #endif /* i386_TARGET_ARCH */
2699 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2701 #if sparc_TARGET_ARCH
2703 -- Floating point assignment to memory
2704 assignMem_FltCode pk addr src
2705 = getNewRegNCG pk `thenNat` \ tmp1 ->
2706 getAmode addr `thenNat` \ amode ->
2707 getRegister src `thenNat` \ register ->
2709 sz = primRepToSize pk
2710 dst__2 = amodeAddr amode
2712 code1 = amodeCode amode
2713 code2 = registerCode register tmp1
2715 src__2 = registerName register tmp1
2716 pk__2 = registerRep register
2717 sz__2 = primRepToSize pk__2
2719 code__2 = code1 `appOL` code2 `appOL`
2721 then unitOL (ST sz src__2 dst__2)
2722 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2726 -- Floating point assignment to a register/temporary
2727 -- Why is this so bizarrely ugly?
2728 assignReg_FltCode pk reg src
2729 = getRegisterReg reg `thenNat` \ register1 ->
2730 getRegister src `thenNat` \ register2 ->
2732 pk__2 = registerRep register2
2733 sz__2 = primRepToSize pk__2
2735 getNewRegNCG pk__2 `thenNat` \ tmp ->
2737 sz = primRepToSize pk
2738 dst__2 = registerName register1 g0 -- must be Fixed
2739 reg__2 = if pk /= pk__2 then tmp else dst__2
2740 code = registerCode register2 reg__2
2741 src__2 = registerName register2 reg__2
2744 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2745 else if isFixed register2 then
2746 code `snocOL` FMOV sz src__2 dst__2
2752 #endif /* sparc_TARGET_ARCH */
2754 #if powerpc_TARGET_ARCH
2756 -- Floating point assignment to memory
2757 assignMem_FltCode pk addr src
2758 = getNewRegNCG pk `thenNat` \ tmp1 ->
2759 getAmode addr `thenNat` \ amode ->
2760 getRegister src `thenNat` \ register ->
2762 sz = primRepToSize pk
2763 dst__2 = amodeAddr amode
2765 code1 = amodeCode amode
2766 code2 = registerCode register tmp1
2768 src__2 = registerName register tmp1
2769 pk__2 = registerRep register
2771 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2775 -- Floating point assignment to a register/temporary
2776 assignReg_FltCode pk reg src
2777 = getRegisterReg reg `thenNat` \ reg_dst ->
2778 getRegister src `thenNat` \ reg_src ->
2779 getNewRegNCG pk `thenNat` \ tmp ->
2781 r_dst = registerName reg_dst tmp
2782 r_src = registerName reg_src r_dst
2783 c_src = registerCode reg_src r_dst
2785 code = if isFixed reg_src
2786 then c_src `snocOL` MR r_dst r_src
2790 #endif /* powerpc_TARGET_ARCH */
2792 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2795 %************************************************************************
2797 \subsection{Generating an unconditional branch}
2799 %************************************************************************
2801 We accept two types of targets: an immediate CLabel or a tree that
2802 gets evaluated into a register. Any CLabels which are AsmTemporaries
2803 are assumed to be in the local block of code, close enough for a
2804 branch instruction. Other CLabels are assumed to be far away.
2806 (If applicable) Do not fill the delay slots here; you will confuse the
2810 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2812 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2814 #if alpha_TARGET_ARCH
2816 genJump (StCLbl lbl)
2817 | isAsmTemp lbl = returnInstr (BR target)
2818 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2820 target = ImmCLbl lbl
2823 = getRegister tree `thenNat` \ register ->
2824 getNewRegNCG PtrRep `thenNat` \ tmp ->
2826 dst = registerName register pv
2827 code = registerCode register pv
2828 target = registerName register pv
2830 if isFixed register then
2831 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2833 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2835 #endif /* alpha_TARGET_ARCH */
2837 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2839 #if i386_TARGET_ARCH
2841 genJump dsts (StInd pk mem)
2842 = getAmode mem `thenNat` \ amode ->
2844 code = amodeCode amode
2845 target = amodeAddr amode
2847 returnNat (code `snocOL` JMP dsts (OpAddr target))
2851 = returnNat (unitOL (JMP dsts (OpImm target)))
2854 = getRegister tree `thenNat` \ register ->
2855 getNewRegNCG PtrRep `thenNat` \ tmp ->
2857 code = registerCode register tmp
2858 target = registerName register tmp
2860 returnNat (code `snocOL` JMP dsts (OpReg target))
2863 target = case imm of Just x -> x
2865 #endif /* i386_TARGET_ARCH */
2867 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2869 #if sparc_TARGET_ARCH
2871 genJump dsts (StCLbl lbl)
2872 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2873 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2874 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2876 target = ImmCLbl lbl
2879 = getRegister tree `thenNat` \ register ->
2880 getNewRegNCG PtrRep `thenNat` \ tmp ->
2882 code = registerCode register tmp
2883 target = registerName register tmp
2885 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2887 #endif /* sparc_TARGET_ARCH */
2889 #if powerpc_TARGET_ARCH
2890 genJump dsts (StCLbl lbl)
2891 | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
2892 | otherwise = returnNat (toOL [BCC ALWAYS lbl])
2895 = getRegister tree `thenNat` \ register ->
2896 getNewRegNCG PtrRep `thenNat` \ tmp ->
2898 code = registerCode register tmp
2899 target = registerName register tmp
2901 returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
2902 #endif /* sparc_TARGET_ARCH */
2904 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2906 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2909 %************************************************************************
2911 \subsection{Conditional jumps}
2913 %************************************************************************
2915 Conditional jumps are always to local labels, so we can use branch
2916 instructions. We peek at the arguments to decide what kind of
2919 ALPHA: For comparisons with 0, we're laughing, because we can just do
2920 the desired conditional branch.
2922 I386: First, we have to ensure that the condition
2923 codes are set according to the supplied comparison operation.
2925 SPARC: First, we have to ensure that the condition codes are set
2926 according to the supplied comparison operation. We generate slightly
2927 different code for floating point comparisons, because a floating
2928 point operation cannot directly precede a @BF@. We assume the worst
2929 and fill that slot with a @NOP@.
2931 SPARC: Do not fill the delay slots here; you will confuse the register
2936 :: CLabel -- the branch target
2937 -> StixExpr -- the condition on which to branch
2940 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2942 #if alpha_TARGET_ARCH
2944 genCondJump lbl (StPrim op [x, StInt 0])
2945 = getRegister x `thenNat` \ register ->
2946 getNewRegNCG (registerRep register)
2949 code = registerCode register tmp
2950 value = registerName register tmp
2951 pk = registerRep register
2952 target = ImmCLbl lbl
2954 returnSeq code [BI (cmpOp op) value target]
2956 cmpOp CharGtOp = GTT
2958 cmpOp CharEqOp = EQQ
2960 cmpOp CharLtOp = LTT
2969 cmpOp WordGeOp = ALWAYS
2970 cmpOp WordEqOp = EQQ
2972 cmpOp WordLtOp = NEVER
2973 cmpOp WordLeOp = EQQ
2975 cmpOp AddrGeOp = ALWAYS
2976 cmpOp AddrEqOp = EQQ
2978 cmpOp AddrLtOp = NEVER
2979 cmpOp AddrLeOp = EQQ
2981 genCondJump lbl (StPrim op [x, StDouble 0.0])
2982 = getRegister x `thenNat` \ register ->
2983 getNewRegNCG (registerRep register)
2986 code = registerCode register tmp
2987 value = registerName register tmp
2988 pk = registerRep register
2989 target = ImmCLbl lbl
2991 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2993 cmpOp FloatGtOp = GTT
2994 cmpOp FloatGeOp = GE
2995 cmpOp FloatEqOp = EQQ
2996 cmpOp FloatNeOp = NE
2997 cmpOp FloatLtOp = LTT
2998 cmpOp FloatLeOp = LE
2999 cmpOp DoubleGtOp = GTT
3000 cmpOp DoubleGeOp = GE
3001 cmpOp DoubleEqOp = EQQ
3002 cmpOp DoubleNeOp = NE
3003 cmpOp DoubleLtOp = LTT
3004 cmpOp DoubleLeOp = LE
3006 genCondJump lbl (StPrim op [x, y])
3008 = trivialFCode pr instr x y `thenNat` \ register ->
3009 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3011 code = registerCode register tmp
3012 result = registerName register tmp
3013 target = ImmCLbl lbl
3015 returnNat (code . mkSeqInstr (BF cond result target))
3017 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
3019 fltCmpOp op = case op of
3033 (instr, cond) = case op of
3034 FloatGtOp -> (FCMP TF LE, EQQ)
3035 FloatGeOp -> (FCMP TF LTT, EQQ)
3036 FloatEqOp -> (FCMP TF EQQ, NE)
3037 FloatNeOp -> (FCMP TF EQQ, EQQ)
3038 FloatLtOp -> (FCMP TF LTT, NE)
3039 FloatLeOp -> (FCMP TF LE, NE)
3040 DoubleGtOp -> (FCMP TF LE, EQQ)
3041 DoubleGeOp -> (FCMP TF LTT, EQQ)
3042 DoubleEqOp -> (FCMP TF EQQ, NE)
3043 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3044 DoubleLtOp -> (FCMP TF LTT, NE)
3045 DoubleLeOp -> (FCMP TF LE, NE)
3047 genCondJump lbl (StPrim op [x, y])
3048 = trivialCode instr x y `thenNat` \ register ->
3049 getNewRegNCG IntRep `thenNat` \ tmp ->
3051 code = registerCode register tmp
3052 result = registerName register tmp
3053 target = ImmCLbl lbl
3055 returnNat (code . mkSeqInstr (BI cond result target))
3057 (instr, cond) = case op of
3058 CharGtOp -> (CMP LE, EQQ)
3059 CharGeOp -> (CMP LTT, EQQ)
3060 CharEqOp -> (CMP EQQ, NE)
3061 CharNeOp -> (CMP EQQ, EQQ)
3062 CharLtOp -> (CMP LTT, NE)
3063 CharLeOp -> (CMP LE, NE)
3064 IntGtOp -> (CMP LE, EQQ)
3065 IntGeOp -> (CMP LTT, EQQ)
3066 IntEqOp -> (CMP EQQ, NE)
3067 IntNeOp -> (CMP EQQ, EQQ)
3068 IntLtOp -> (CMP LTT, NE)
3069 IntLeOp -> (CMP LE, NE)
3070 WordGtOp -> (CMP ULE, EQQ)
3071 WordGeOp -> (CMP ULT, EQQ)
3072 WordEqOp -> (CMP EQQ, NE)
3073 WordNeOp -> (CMP EQQ, EQQ)
3074 WordLtOp -> (CMP ULT, NE)
3075 WordLeOp -> (CMP ULE, NE)
3076 AddrGtOp -> (CMP ULE, EQQ)
3077 AddrGeOp -> (CMP ULT, EQQ)
3078 AddrEqOp -> (CMP EQQ, NE)
3079 AddrNeOp -> (CMP EQQ, EQQ)
3080 AddrLtOp -> (CMP ULT, NE)
3081 AddrLeOp -> (CMP ULE, NE)
3083 #endif /* alpha_TARGET_ARCH */
3085 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3087 #if i386_TARGET_ARCH
3089 genCondJump lbl bool
3090 = getCondCode bool `thenNat` \ condition ->
3092 code = condCode condition
3093 cond = condName condition
3095 returnNat (code `snocOL` JXX cond lbl)
3097 #endif /* i386_TARGET_ARCH */
3099 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3101 #if sparc_TARGET_ARCH
3103 genCondJump lbl bool
3104 = getCondCode bool `thenNat` \ condition ->
3106 code = condCode condition
3107 cond = condName condition
3108 target = ImmCLbl lbl
3113 if condFloat condition
3114 then [NOP, BF cond False target, NOP]
3115 else [BI cond False target, NOP]
3119 #endif /* sparc_TARGET_ARCH */
3121 #if powerpc_TARGET_ARCH
3123 genCondJump lbl bool
3124 = getCondCode bool `thenNat` \ condition ->
3126 code = condCode condition
3127 cond = condName condition
3128 target = ImmCLbl lbl
3131 code `snocOL` BCC cond lbl )
3133 #endif /* powerpc_TARGET_ARCH */
3135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3137 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3140 %************************************************************************
3142 \subsection{Generating C calls}
3144 %************************************************************************
3146 Now the biggest nightmare---calls. Most of the nastiness is buried in
3147 @get_arg@, which moves the arguments to the correct registers/stack
3148 locations. Apart from that, the code is easy.
3150 (If applicable) Do not fill the delay slots here; you will confuse the
3155 :: (Either FastString StixExpr) -- function to call
3157 -> PrimRep -- type of the result
3158 -> [StixExpr] -- arguments (of mixed type)
3161 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3163 #if alpha_TARGET_ARCH
3165 genCCall fn cconv kind args
3166 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3167 `thenNat` \ ((unused,_), argCode) ->
3169 nRegs = length allArgRegs - length unused
3170 code = asmSeqThen (map ($ []) argCode)
3173 LDA pv (AddrImm (ImmLab (ptext fn))),
3174 JSR ra (AddrReg pv) nRegs,
3175 LDGP gp (AddrReg ra)]
3177 ------------------------
3178 {- Try to get a value into a specific register (or registers) for
3179 a call. The first 6 arguments go into the appropriate
3180 argument register (separate registers for integer and floating
3181 point arguments, but used in lock-step), and the remaining
3182 arguments are dumped to the stack, beginning at 0(sp). Our
3183 first argument is a pair of the list of remaining argument
3184 registers to be assigned for this call and the next stack
3185 offset to use for overflowing arguments. This way,
3186 @get_Arg@ can be applied to all of a call's arguments using
3190 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3191 -> StixTree -- Current argument
3192 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3194 -- We have to use up all of our argument registers first...
3196 get_arg ((iDst,fDst):dsts, offset) arg
3197 = getRegister arg `thenNat` \ register ->
3199 reg = if isFloatingRep pk then fDst else iDst
3200 code = registerCode register reg
3201 src = registerName register reg
3202 pk = registerRep register
3205 if isFloatingRep pk then
3206 ((dsts, offset), if isFixed register then
3207 code . mkSeqInstr (FMOV src fDst)
3210 ((dsts, offset), if isFixed register then
3211 code . mkSeqInstr (OR src (RIReg src) iDst)
3214 -- Once we have run out of argument registers, we move to the
3217 get_arg ([], offset) arg
3218 = getRegister arg `thenNat` \ register ->
3219 getNewRegNCG (registerRep register)
3222 code = registerCode register tmp
3223 src = registerName register tmp
3224 pk = registerRep register
3225 sz = primRepToSize pk
3227 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3229 #endif /* alpha_TARGET_ARCH */
3231 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3233 #if i386_TARGET_ARCH
3235 genCCall fn cconv ret_rep args
3237 (reverse args) `thenNat` \ sizes_n_codes ->
3238 getDeltaNat `thenNat` \ delta ->
3239 let (sizes, push_codes) = unzip sizes_n_codes
3240 tot_arg_size = sum sizes
3242 -- deal with static vs dynamic call targets
3245 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3247 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3248 ASSERT(case dyn_rep of { L -> True; _ -> False})
3249 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3251 `thenNat` \ callinsns ->
3252 let push_code = concatOL push_codes
3253 call = callinsns `appOL`
3255 -- Deallocate parameters after call for ccall;
3256 -- but not for stdcall (callee does it)
3257 (if cconv == StdCallConv then [] else
3258 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3260 [DELTA (delta + tot_arg_size)]
3263 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3264 returnNat (push_code `appOL` call)
3267 -- function names that begin with '.' are assumed to be special
3268 -- internally generated names like '.mul,' which don't get an
3269 -- underscore prefix
3270 -- ToDo:needed (WDP 96/03) ???
3271 fn_u = unpackFS (unLeft fn)
3274 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3275 | otherwise -- General case
3276 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3278 stdcallsize tot_arg_size
3279 | cconv == StdCallConv = '@':show tot_arg_size
3287 push_arg :: StixExpr{-current argument-}
3288 -> NatM (Int, InstrBlock) -- argsz, code
3291 | is64BitRep arg_rep
3292 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3293 getDeltaNat `thenNat` \ delta ->
3294 setDeltaNat (delta - 8) `thenNat` \ _ ->
3295 let r_lo = VirtualRegI vr_lo
3296 r_hi = getHiVRegFromLo r_lo
3299 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3300 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3303 = get_op arg `thenNat` \ (code, reg, sz) ->
3304 getDeltaNat `thenNat` \ delta ->
3305 arg_size sz `bind` \ size ->
3306 setDeltaNat (delta-size) `thenNat` \ _ ->
3307 if (case sz of DF -> True; F -> True; _ -> False)
3308 then returnNat (size,
3310 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3312 GST sz reg (AddrBaseIndex (Just esp)
3316 else returnNat (size,
3318 PUSH L (OpReg reg) `snocOL`
3322 arg_rep = repOfStixExpr arg
3327 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3330 = getRegister op `thenNat` \ register ->
3331 getNewRegNCG (registerRep register)
3334 code = registerCode register tmp
3335 reg = registerName register tmp
3336 pk = registerRep register
3337 sz = primRepToSize pk
3339 returnNat (code, reg, sz)
3341 #endif /* i386_TARGET_ARCH */
3343 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3345 #if sparc_TARGET_ARCH
3347 The SPARC calling convention is an absolute
3348 nightmare. The first 6x32 bits of arguments are mapped into
3349 %o0 through %o5, and the remaining arguments are dumped to the
3350 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3352 If we have to put args on the stack, move %o6==%sp down by
3353 the number of words to go on the stack, to ensure there's enough space.
3355 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3356 16 words above the stack pointer is a word for the address of
3357 a structure return value. I use this as a temporary location
3358 for moving values from float to int regs. Certainly it isn't
3359 safe to put anything in the 16 words starting at %sp, since
3360 this area can get trashed at any time due to window overflows
3361 caused by signal handlers.
3363 A final complication (if the above isn't enough) is that
3364 we can't blithely calculate the arguments one by one into
3365 %o0 .. %o5. Consider the following nested calls:
3369 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3370 the inner call will itself use %o0, which trashes the value put there
3371 in preparation for the outer call. Upshot: we need to calculate the
3372 args into temporary regs, and move those to arg regs or onto the
3373 stack only immediately prior to the call proper. Sigh.
3376 genCCall fn cconv kind args
3377 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3379 (argcodes, vregss) = unzip argcode_and_vregs
3380 n_argRegs = length allArgRegs
3381 n_argRegs_used = min (length vregs) n_argRegs
3382 vregs = concat vregss
3384 -- deal with static vs dynamic call targets
3387 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3389 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3390 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3392 `thenNat` \ callinsns ->
3394 argcode = concatOL argcodes
3395 (move_sp_down, move_sp_up)
3396 = let diff = length vregs - n_argRegs
3397 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3400 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3402 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3404 returnNat (argcode `appOL`
3405 move_sp_down `appOL`
3406 transfer_code `appOL`
3411 -- function names that begin with '.' are assumed to be special
3412 -- internally generated names like '.mul,' which don't get an
3413 -- underscore prefix
3414 -- ToDo:needed (WDP 96/03) ???
3415 fn_static = unLeft fn
3416 fn__2 = case (headFS fn_static) of
3417 '.' -> ImmLit (ftext fn_static)
3418 _ -> ImmLab False (ftext fn_static)
3420 -- move args from the integer vregs into which they have been
3421 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3422 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3424 move_final [] _ offset -- all args done
3427 move_final (v:vs) [] offset -- out of aregs; move to stack
3428 = ST W v (spRel offset)
3429 : move_final vs [] (offset+1)
3431 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3432 = OR False g0 (RIReg v) a
3433 : move_final vs az offset
3435 -- generate code to calculate an argument, and move it into one
3436 -- or two integer vregs.
3437 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3438 arg_to_int_vregs arg
3439 | is64BitRep (repOfStixExpr arg)
3440 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3441 let r_lo = VirtualRegI vr_lo
3442 r_hi = getHiVRegFromLo r_lo
3443 in returnNat (code, [r_hi, r_lo])
3445 = getRegister arg `thenNat` \ register ->
3446 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3447 let code = registerCode register tmp
3448 src = registerName register tmp
3449 pk = registerRep register
3451 -- the value is in src. Get it into 1 or 2 int vregs.
3454 getNewRegNCG WordRep `thenNat` \ v1 ->
3455 getNewRegNCG WordRep `thenNat` \ v2 ->
3458 FMOV DF src f0 `snocOL`
3459 ST F f0 (spRel 16) `snocOL`
3460 LD W (spRel 16) v1 `snocOL`
3461 ST F (fPair f0) (spRel 16) `snocOL`
3467 getNewRegNCG WordRep `thenNat` \ v1 ->
3470 ST F src (spRel 16) `snocOL`
3476 getNewRegNCG WordRep `thenNat` \ v1 ->
3478 code `snocOL` OR False g0 (RIReg src) v1
3482 #endif /* sparc_TARGET_ARCH */
3484 #if powerpc_TARGET_ARCH
3486 #if darwin_TARGET_OS
3488 The PowerPC calling convention for Darwin/Mac OS X
3489 is described in Apple's document
3490 "Inside Mac OS X - Mach-O Runtime Architecture".
3491 Parameters may be passed in general-purpose registers, in
3492 floating point registers, or on the stack. Stack space is
3493 always reserved for parameters, even if they are passed in registers.
3494 The called routine may choose to save parameters from registers
3495 to the corresponding space on the stack.
3496 The parameter area should be part of the caller's stack frame,
3497 allocated in the caller's prologue code (large enough to hold
3498 the parameter lists for all called routines). The NCG already
3499 uses the space that we should use as a parameter area for register
3500 spilling, so we allocate a new stack frame just before ccalling.
3501 That way we don't need to decide beforehand how much space to
3502 reserve for parameters.
3505 genCCall fn cconv kind args
3506 = mapNat prepArg args `thenNat` \ preppedArgs ->
3508 (argReps,argCodes,vregs) = unzip3 preppedArgs
3510 -- size of linkage area + size of arguments, in bytes
3511 stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3512 roundTo16 x | x `mod` 16 == 0 = x
3513 | otherwise = x + 16 - (x `mod` 16)
3515 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3516 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3518 (moveFinalCode,usedRegs) = move_final
3520 allArgRegs allFPArgRegs
3524 passArguments = concatOL argCodes
3525 `appOL` move_sp_down
3526 `appOL` moveFinalCode
3530 addImportNat lbl `thenNat` \ _ ->
3531 returnNat (passArguments
3532 `snocOL` BL (ImmLit $ ftext
3535 `appendFS` FSLIT("$stub")))
3539 getRegister dyn `thenNat` \ dynReg ->
3540 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3541 returnNat (registerCode dynReg tmp
3542 `appOL` passArguments
3543 `snocOL` MTCTR (registerName dynReg tmp)
3544 `snocOL` BCTRL usedRegs
3548 | is64BitRep (repOfStixExpr arg)
3549 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3550 let r_lo = VirtualRegI vr_lo
3551 r_hi = getHiVRegFromLo r_lo
3552 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3554 = getRegister arg `thenNat` \ register ->
3555 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3556 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3557 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3558 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3559 | not (is64BitRep rep) =
3562 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3565 fpr : fprs -> MR fpr vr
3566 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3567 ((take 1 fprs) ++ accumUsed)
3569 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3572 fpr : fprs -> MR fpr vr
3573 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3574 ((take 1 fprs) ++ accumUsed)
3575 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3577 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3580 gpr : gprs -> MR gpr vr
3581 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3582 ((take 1 gprs) ++ accumUsed)
3584 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3587 storeWord vr (gpr:_) offset = MR gpr vr
3588 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3590 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3592 `snocOL` storeWord vr_hi gprs stackOffset
3593 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3594 ((take 2 gprs) ++ accumUsed)
3598 PowerPC Linux uses the System V Release 4 Calling Convention
3599 for PowerPC. It is described in the
3600 "System V Application Binary Interface PowerPC Processor Supplement".
3602 Like the Darwin/Mac OS X code above, this allocates a new stack frame
3603 so that the parameter area doesn't conflict with the spill slots.
3606 genCCall fn cconv kind args
3607 = mapNat prepArg args `thenNat` \ preppedArgs ->
3609 (argReps,argCodes,vregs) = unzip3 preppedArgs
3611 -- size of linkage area + size of arguments, in bytes
3612 stackDelta = roundTo16 finalStack
3613 roundTo16 x | x `mod` 16 == 0 = x
3614 | otherwise = x + 16 - (x `mod` 16)
3616 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3617 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3619 (moveFinalCode,usedRegs,finalStack) =
3620 move_final (zip vregs argReps)
3621 allArgRegs allFPArgRegs
3625 passArguments = concatOL argCodes
3626 `appOL` move_sp_down
3627 `appOL` moveFinalCode
3631 addImportNat lbl `thenNat` \ _ ->
3632 returnNat (passArguments
3633 `snocOL` BL (ImmLit $ ftext lbl)
3637 getRegister dyn `thenNat` \ dynReg ->
3638 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3639 returnNat (registerCode dynReg tmp
3640 `appOL` passArguments
3641 `snocOL` MTCTR (registerName dynReg tmp)
3642 `snocOL` BCTRL usedRegs
3646 | is64BitRep (repOfStixExpr arg)
3647 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3648 let r_lo = VirtualRegI vr_lo
3649 r_hi = getHiVRegFromLo r_lo
3650 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3652 = getRegister arg `thenNat` \ register ->
3653 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3654 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3655 move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
3656 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3657 | not (is64BitRep rep) =
3661 fpr : fprs' -> move_final vregs gprs fprs' stackOffset
3662 (accumCode `snocOL` MR fpr vr)
3664 [] -> move_final vregs gprs fprs (stackOffset+4)
3666 ST F vr (AddrRegImm sp (ImmInt stackOffset)))
3670 fpr : fprs' -> move_final vregs gprs fprs' stackOffset
3671 (accumCode `snocOL` MR fpr vr)
3673 [] -> move_final vregs gprs fprs (stackOffset+8)
3675 ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
3677 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3680 gpr : gprs' -> move_final vregs gprs' fprs stackOffset
3681 (accumCode `snocOL` MR gpr vr)
3683 [] -> move_final vregs gprs fprs (stackOffset+4)
3685 ST W vr (AddrRegImm sp (ImmInt stackOffset)))
3688 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3691 hireg : loreg : regs | even (length gprs) ->
3692 move_final vregs regs fprs stackOffset
3693 (regCode hireg loreg) accumUsed
3694 _skipped : hireg : loreg : regs ->
3695 move_final vregs regs fprs stackOffset
3696 (regCode hireg loreg) accumUsed
3697 _ -> -- only one or no regs left
3698 move_final vregs [] fprs (stackOffset+8)
3703 `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
3704 `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
3705 regCode hireg loreg =
3707 `snocOL` MR hireg vr_hi
3708 `snocOL` MR loreg vr_lo
3712 #endif /* powerpc_TARGET_ARCH */
3714 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3717 %************************************************************************
3719 \subsection{Support bits}
3721 %************************************************************************
3723 %************************************************************************
3725 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3727 %************************************************************************
3729 Turn those condition codes into integers now (when they appear on
3730 the right hand side of an assignment).
3732 (If applicable) Do not fill the delay slots here; you will confuse the
3736 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3738 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3740 #if alpha_TARGET_ARCH
3741 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3742 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3743 #endif /* alpha_TARGET_ARCH */
3745 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3747 #if i386_TARGET_ARCH
3750 = condIntCode cond x y `thenNat` \ condition ->
3751 getNewRegNCG IntRep `thenNat` \ tmp ->
3753 code = condCode condition
3754 cond = condName condition
3755 code__2 dst = code `appOL` toOL [
3756 SETCC cond (OpReg tmp),
3757 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3758 MOV L (OpReg tmp) (OpReg dst)]
3760 returnNat (Any IntRep code__2)
3763 = getNatLabelNCG `thenNat` \ lbl1 ->
3764 getNatLabelNCG `thenNat` \ lbl2 ->
3765 condFltCode cond x y `thenNat` \ condition ->
3767 code = condCode condition
3768 cond = condName condition
3769 code__2 dst = code `appOL` toOL [
3771 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3774 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3777 returnNat (Any IntRep code__2)
3779 #endif /* i386_TARGET_ARCH */
3781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3783 #if sparc_TARGET_ARCH
3785 condIntReg EQQ x (StInt 0)
3786 = getRegister x `thenNat` \ register ->
3787 getNewRegNCG IntRep `thenNat` \ tmp ->
3789 code = registerCode register tmp
3790 src = registerName register tmp
3791 code__2 dst = code `appOL` toOL [
3792 SUB False True g0 (RIReg src) g0,
3793 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3795 returnNat (Any IntRep code__2)
3798 = getRegister x `thenNat` \ register1 ->
3799 getRegister y `thenNat` \ register2 ->
3800 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3801 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3803 code1 = registerCode register1 tmp1
3804 src1 = registerName register1 tmp1
3805 code2 = registerCode register2 tmp2
3806 src2 = registerName register2 tmp2
3807 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3808 XOR False src1 (RIReg src2) dst,
3809 SUB False True g0 (RIReg dst) g0,
3810 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3812 returnNat (Any IntRep code__2)
3814 condIntReg NE x (StInt 0)
3815 = getRegister x `thenNat` \ register ->
3816 getNewRegNCG IntRep `thenNat` \ tmp ->
3818 code = registerCode register tmp
3819 src = registerName register tmp
3820 code__2 dst = code `appOL` toOL [
3821 SUB False True g0 (RIReg src) g0,
3822 ADD True False g0 (RIImm (ImmInt 0)) dst]
3824 returnNat (Any IntRep code__2)
3827 = getRegister x `thenNat` \ register1 ->
3828 getRegister y `thenNat` \ register2 ->
3829 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3830 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3832 code1 = registerCode register1 tmp1
3833 src1 = registerName register1 tmp1
3834 code2 = registerCode register2 tmp2
3835 src2 = registerName register2 tmp2
3836 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3837 XOR False src1 (RIReg src2) dst,
3838 SUB False True g0 (RIReg dst) g0,
3839 ADD True False g0 (RIImm (ImmInt 0)) dst]
3841 returnNat (Any IntRep code__2)
3844 = getNatLabelNCG `thenNat` \ lbl1 ->
3845 getNatLabelNCG `thenNat` \ lbl2 ->
3846 condIntCode cond x y `thenNat` \ condition ->
3848 code = condCode condition
3849 cond = condName condition
3850 code__2 dst = code `appOL` toOL [
3851 BI cond False (ImmCLbl lbl1), NOP,
3852 OR False g0 (RIImm (ImmInt 0)) dst,
3853 BI ALWAYS False (ImmCLbl lbl2), NOP,
3855 OR False g0 (RIImm (ImmInt 1)) dst,
3858 returnNat (Any IntRep code__2)
3861 = getNatLabelNCG `thenNat` \ lbl1 ->
3862 getNatLabelNCG `thenNat` \ lbl2 ->
3863 condFltCode cond x y `thenNat` \ condition ->
3865 code = condCode condition
3866 cond = condName condition
3867 code__2 dst = code `appOL` toOL [
3869 BF cond False (ImmCLbl lbl1), NOP,
3870 OR False g0 (RIImm (ImmInt 0)) dst,
3871 BI ALWAYS False (ImmCLbl lbl2), NOP,
3873 OR False g0 (RIImm (ImmInt 1)) dst,
3876 returnNat (Any IntRep code__2)
3878 #endif /* sparc_TARGET_ARCH */
3880 #if powerpc_TARGET_ARCH
3882 = getNatLabelNCG `thenNat` \ lbl ->
3883 condIntCode cond x y `thenNat` \ condition ->
3885 code = condCode condition
3886 cond = condName condition
3887 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3892 returnNat (Any IntRep code__2)
3895 = getNatLabelNCG `thenNat` \ lbl ->
3896 condFltCode cond x y `thenNat` \ condition ->
3898 code = condCode condition
3899 cond = condName condition
3900 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3905 returnNat (Any IntRep code__2)
3906 #endif /* powerpc_TARGET_ARCH */
3908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3911 %************************************************************************
3913 \subsubsection{@trivial*Code@: deal with trivial instructions}
3915 %************************************************************************
3917 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3918 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3919 for constants on the right hand side, because that's where the generic
3920 optimizer will have put them.
3922 Similarly, for unary instructions, we don't have to worry about
3923 matching an StInt as the argument, because genericOpt will already
3924 have handled the constant-folding.
3928 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3929 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3930 -> Maybe (Operand -> Operand -> Instr)
3931 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3932 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3934 -> StixExpr -> StixExpr -- the two arguments
3939 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3940 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3941 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3942 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3944 -> StixExpr -> StixExpr -- the two arguments
3948 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3949 ,IF_ARCH_i386 ((Operand -> Instr)
3950 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3951 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3953 -> StixExpr -- the one argument
3958 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3959 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3960 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3961 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3963 -> StixExpr -- the one argument
3966 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3968 #if alpha_TARGET_ARCH
3970 trivialCode instr x (StInt y)
3972 = getRegister x `thenNat` \ register ->
3973 getNewRegNCG IntRep `thenNat` \ tmp ->
3975 code = registerCode register tmp
3976 src1 = registerName register tmp
3977 src2 = ImmInt (fromInteger y)
3978 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3980 returnNat (Any IntRep code__2)
3982 trivialCode instr x y
3983 = getRegister x `thenNat` \ register1 ->
3984 getRegister y `thenNat` \ register2 ->
3985 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3986 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3988 code1 = registerCode register1 tmp1 []
3989 src1 = registerName register1 tmp1
3990 code2 = registerCode register2 tmp2 []
3991 src2 = registerName register2 tmp2
3992 code__2 dst = asmSeqThen [code1, code2] .
3993 mkSeqInstr (instr src1 (RIReg src2) dst)
3995 returnNat (Any IntRep code__2)
3998 trivialUCode instr x
3999 = getRegister x `thenNat` \ register ->
4000 getNewRegNCG IntRep `thenNat` \ tmp ->
4002 code = registerCode register tmp
4003 src = registerName register tmp
4004 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
4006 returnNat (Any IntRep code__2)
4009 trivialFCode _ instr x y
4010 = getRegister x `thenNat` \ register1 ->
4011 getRegister y `thenNat` \ register2 ->
4012 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4013 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4015 code1 = registerCode register1 tmp1
4016 src1 = registerName register1 tmp1
4018 code2 = registerCode register2 tmp2
4019 src2 = registerName register2 tmp2
4021 code__2 dst = asmSeqThen [code1 [], code2 []] .
4022 mkSeqInstr (instr src1 src2 dst)
4024 returnNat (Any DoubleRep code__2)
4026 trivialUFCode _ instr x
4027 = getRegister x `thenNat` \ register ->
4028 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4030 code = registerCode register tmp
4031 src = registerName register tmp
4032 code__2 dst = code . mkSeqInstr (instr src dst)
4034 returnNat (Any DoubleRep code__2)
4036 #endif /* alpha_TARGET_ARCH */
4038 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4040 #if i386_TARGET_ARCH
4042 The Rules of the Game are:
4044 * You cannot assume anything about the destination register dst;
4045 it may be anything, including a fixed reg.
4047 * You may compute an operand into a fixed reg, but you may not
4048 subsequently change the contents of that fixed reg. If you
4049 want to do so, first copy the value either to a temporary
4050 or into dst. You are free to modify dst even if it happens
4051 to be a fixed reg -- that's not your problem.
4053 * You cannot assume that a fixed reg will stay live over an
4054 arbitrary computation. The same applies to the dst reg.
4056 * Temporary regs obtained from getNewRegNCG are distinct from
4057 each other and from all other regs, and stay live over
4058 arbitrary computations.
4062 trivialCode instr maybe_revinstr a b
4065 = getRegister a `thenNat` \ rega ->
4068 then registerCode rega dst `bind` \ code_a ->
4070 instr (OpImm imm_b) (OpReg dst)
4071 else registerCodeF rega `bind` \ code_a ->
4072 registerNameF rega `bind` \ r_a ->
4074 MOV L (OpReg r_a) (OpReg dst) `snocOL`
4075 instr (OpImm imm_b) (OpReg dst)
4077 returnNat (Any IntRep mkcode)
4080 = getRegister b `thenNat` \ regb ->
4081 getNewRegNCG IntRep `thenNat` \ tmp ->
4082 let revinstr_avail = maybeToBool maybe_revinstr
4083 revinstr = case maybe_revinstr of Just ri -> ri
4087 then registerCode regb dst `bind` \ code_b ->
4089 revinstr (OpImm imm_a) (OpReg dst)
4090 else registerCodeF regb `bind` \ code_b ->
4091 registerNameF regb `bind` \ r_b ->
4093 MOV L (OpReg r_b) (OpReg dst) `snocOL`
4094 revinstr (OpImm imm_a) (OpReg dst)
4098 then registerCode regb tmp `bind` \ code_b ->
4100 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
4101 instr (OpReg tmp) (OpReg dst)
4102 else registerCodeF regb `bind` \ code_b ->
4103 registerNameF regb `bind` \ r_b ->
4105 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
4106 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
4107 instr (OpReg tmp) (OpReg dst)
4109 returnNat (Any IntRep mkcode)
4112 = getRegister a `thenNat` \ rega ->
4113 getRegister b `thenNat` \ regb ->
4114 getNewRegNCG IntRep `thenNat` \ tmp ->
4116 = case (isAny rega, isAny regb) of
4118 -> registerCode regb tmp `bind` \ code_b ->
4119 registerCode rega dst `bind` \ code_a ->
4122 instr (OpReg tmp) (OpReg dst)
4124 -> registerCode rega tmp `bind` \ code_a ->
4125 registerCodeF regb `bind` \ code_b ->
4126 registerNameF regb `bind` \ r_b ->
4129 instr (OpReg r_b) (OpReg tmp) `snocOL`
4130 MOV L (OpReg tmp) (OpReg dst)
4132 -> registerCode regb tmp `bind` \ code_b ->
4133 registerCodeF rega `bind` \ code_a ->
4134 registerNameF rega `bind` \ r_a ->
4137 MOV L (OpReg r_a) (OpReg dst) `snocOL`
4138 instr (OpReg tmp) (OpReg dst)
4140 -> registerCodeF rega `bind` \ code_a ->
4141 registerNameF rega `bind` \ r_a ->
4142 registerCodeF regb `bind` \ code_b ->
4143 registerNameF regb `bind` \ r_b ->
4145 MOV L (OpReg r_a) (OpReg tmp) `appOL`
4147 instr (OpReg r_b) (OpReg tmp) `snocOL`
4148 MOV L (OpReg tmp) (OpReg dst)
4150 returnNat (Any IntRep mkcode)
4153 maybe_imm_a = maybeImm a
4154 is_imm_a = maybeToBool maybe_imm_a
4155 imm_a = case maybe_imm_a of Just imm -> imm
4157 maybe_imm_b = maybeImm b
4158 is_imm_b = maybeToBool maybe_imm_b
4159 imm_b = case maybe_imm_b of Just imm -> imm
4163 trivialUCode instr x
4164 = getRegister x `thenNat` \ register ->
4166 code__2 dst = let code = registerCode register dst
4167 src = registerName register dst
4169 if isFixed register && dst /= src
4170 then toOL [MOV L (OpReg src) (OpReg dst),
4172 else unitOL (instr (OpReg src))
4174 returnNat (Any IntRep code__2)
4177 trivialFCode pk instr x y
4178 = getRegister x `thenNat` \ register1 ->
4179 getRegister y `thenNat` \ register2 ->
4180 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4181 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4183 code1 = registerCode register1 tmp1
4184 src1 = registerName register1 tmp1
4186 code2 = registerCode register2 tmp2
4187 src2 = registerName register2 tmp2
4190 -- treat the common case specially: both operands in
4192 | isAny register1 && isAny register2
4195 instr (primRepToSize pk) src1 src2 dst
4197 -- be paranoid (and inefficient)
4199 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4201 instr (primRepToSize pk) tmp1 src2 dst
4203 returnNat (Any pk code__2)
4207 trivialUFCode pk instr x
4208 = getRegister x `thenNat` \ register ->
4209 getNewRegNCG pk `thenNat` \ tmp ->
4211 code = registerCode register tmp
4212 src = registerName register tmp
4213 code__2 dst = code `snocOL` instr src dst
4215 returnNat (Any pk code__2)
4217 #endif /* i386_TARGET_ARCH */
4219 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4221 #if sparc_TARGET_ARCH
4223 trivialCode instr x (StInt y)
4225 = getRegister x `thenNat` \ register ->
4226 getNewRegNCG IntRep `thenNat` \ tmp ->
4228 code = registerCode register tmp
4229 src1 = registerName register tmp
4230 src2 = ImmInt (fromInteger y)
4231 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4233 returnNat (Any IntRep code__2)
4235 trivialCode instr x y
4236 = getRegister x `thenNat` \ register1 ->
4237 getRegister y `thenNat` \ register2 ->
4238 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4239 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4241 code1 = registerCode register1 tmp1
4242 src1 = registerName register1 tmp1
4243 code2 = registerCode register2 tmp2
4244 src2 = registerName register2 tmp2
4245 code__2 dst = code1 `appOL` code2 `snocOL`
4246 instr src1 (RIReg src2) dst
4248 returnNat (Any IntRep code__2)
4251 trivialFCode pk instr x y
4252 = getRegister x `thenNat` \ register1 ->
4253 getRegister y `thenNat` \ register2 ->
4254 getNewRegNCG (registerRep register1)
4256 getNewRegNCG (registerRep register2)
4258 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4260 promote x = FxTOy F DF x tmp
4262 pk1 = registerRep register1
4263 code1 = registerCode register1 tmp1
4264 src1 = registerName register1 tmp1
4266 pk2 = registerRep register2
4267 code2 = registerCode register2 tmp2
4268 src2 = registerName register2 tmp2
4272 code1 `appOL` code2 `snocOL`
4273 instr (primRepToSize pk) src1 src2 dst
4274 else if pk1 == FloatRep then
4275 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4276 instr DF tmp src2 dst
4278 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4279 instr DF src1 tmp dst
4281 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4284 trivialUCode instr x
4285 = getRegister x `thenNat` \ register ->
4286 getNewRegNCG IntRep `thenNat` \ tmp ->
4288 code = registerCode register tmp
4289 src = registerName register tmp
4290 code__2 dst = code `snocOL` instr (RIReg src) dst
4292 returnNat (Any IntRep code__2)
4295 trivialUFCode pk instr x
4296 = getRegister x `thenNat` \ register ->
4297 getNewRegNCG pk `thenNat` \ tmp ->
4299 code = registerCode register tmp
4300 src = registerName register tmp
4301 code__2 dst = code `snocOL` instr src dst
4303 returnNat (Any pk code__2)
4305 #endif /* sparc_TARGET_ARCH */
4307 #if powerpc_TARGET_ARCH
4308 trivialCode instr x (StInt y)
4310 = getRegister x `thenNat` \ register ->
4311 getNewRegNCG IntRep `thenNat` \ tmp ->
4313 code = registerCode register tmp
4314 src1 = registerName register tmp
4315 src2 = ImmInt (fromInteger y)
4316 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4318 returnNat (Any IntRep code__2)
4320 trivialCode instr x y
4321 = getRegister x `thenNat` \ register1 ->
4322 getRegister y `thenNat` \ register2 ->
4323 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4324 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4326 code1 = registerCode register1 tmp1
4327 src1 = registerName register1 tmp1
4328 code2 = registerCode register2 tmp2
4329 src2 = registerName register2 tmp2
4330 code__2 dst = code1 `appOL` code2 `snocOL`
4331 instr dst src1 (RIReg src2)
4333 returnNat (Any IntRep code__2)
4335 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4336 -> StixExpr -> StixExpr -> NatM Register
4337 trivialCode2 instr x y
4338 = getRegister x `thenNat` \ register1 ->
4339 getRegister y `thenNat` \ register2 ->
4340 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4341 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4343 code1 = registerCode register1 tmp1
4344 src1 = registerName register1 tmp1
4345 code2 = registerCode register2 tmp2
4346 src2 = registerName register2 tmp2
4347 code__2 dst = code1 `appOL` code2 `snocOL`
4350 returnNat (Any IntRep code__2)
4352 trivialFCode pk instr x y
4353 = getRegister x `thenNat` \ register1 ->
4354 getRegister y `thenNat` \ register2 ->
4355 getNewRegNCG (registerRep register1)
4357 getNewRegNCG (registerRep register2)
4359 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4361 -- promote x = FxTOy F DF x tmp
4363 pk1 = registerRep register1
4364 code1 = registerCode register1 tmp1
4365 src1 = registerName register1 tmp1
4367 pk2 = registerRep register2
4368 code2 = registerCode register2 tmp2
4369 src2 = registerName register2 tmp2
4371 dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
4374 code1 `appOL` code2 `snocOL`
4375 instr (primRepToSize dstRep) dst src1 src2
4377 returnNat (Any dstRep code__2)
4379 trivialUCode instr x
4380 = getRegister x `thenNat` \ register ->
4381 getNewRegNCG IntRep `thenNat` \ tmp ->
4383 code = registerCode register tmp
4384 src = registerName register tmp
4385 code__2 dst = code `snocOL` instr dst src
4387 returnNat (Any IntRep code__2)
4388 trivialUFCode pk instr x
4389 = getRegister x `thenNat` \ register ->
4390 getNewRegNCG (registerRep register)
4393 code = registerCode register tmp
4394 src = registerName register tmp
4395 code__2 dst = code `snocOL` instr dst src
4397 returnNat (Any pk code__2)
4399 -- There is no "remainder" instruction on the PPC, so we have to do
4401 -- The "div" parameter is the division instruction to use (DIVW or DIVWU)
4403 remainderCode :: (Reg -> Reg -> Reg -> Instr)
4404 -> StixExpr -> StixExpr -> NatM Register
4405 remainderCode div x y
4406 = getRegister x `thenNat` \ register1 ->
4407 getRegister y `thenNat` \ register2 ->
4408 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4409 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4411 code1 = registerCode register1 tmp1
4412 src1 = registerName register1 tmp1
4413 code2 = registerCode register2 tmp2
4414 src2 = registerName register2 tmp2
4415 code__2 dst = code1 `appOL` code2 `appOL` toOL [
4417 MULLW dst dst (RIReg src2),
4421 returnNat (Any IntRep code__2)
4423 #endif /* powerpc_TARGET_ARCH */
4425 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4428 %************************************************************************
4430 \subsubsection{Coercing to/from integer/floating-point...}
4432 %************************************************************************
4434 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4435 conversions. We have to store temporaries in memory to move
4436 between the integer and the floating point register sets.
4438 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4439 pretend, on sparc at least, that double and float regs are seperate
4440 kinds, so the value has to be computed into one kind before being
4441 explicitly "converted" to live in the other kind.
4444 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4445 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4447 coerceDbl2Flt :: StixExpr -> NatM Register
4448 coerceFlt2Dbl :: StixExpr -> NatM Register
4452 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4454 #if alpha_TARGET_ARCH
4457 = getRegister x `thenNat` \ register ->
4458 getNewRegNCG IntRep `thenNat` \ reg ->
4460 code = registerCode register reg
4461 src = registerName register reg
4463 code__2 dst = code . mkSeqInstrs [
4465 LD TF dst (spRel 0),
4468 returnNat (Any DoubleRep code__2)
4472 = getRegister x `thenNat` \ register ->
4473 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4475 code = registerCode register tmp
4476 src = registerName register tmp
4478 code__2 dst = code . mkSeqInstrs [
4480 ST TF tmp (spRel 0),
4483 returnNat (Any IntRep code__2)
4485 #endif /* alpha_TARGET_ARCH */
4487 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4489 #if i386_TARGET_ARCH
4492 = getRegister x `thenNat` \ register ->
4493 getNewRegNCG IntRep `thenNat` \ reg ->
4495 code = registerCode register reg
4496 src = registerName register reg
4497 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4498 code__2 dst = code `snocOL` opc src dst
4500 returnNat (Any pk code__2)
4503 coerceFP2Int fprep x
4504 = getRegister x `thenNat` \ register ->
4505 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4507 code = registerCode register tmp
4508 src = registerName register tmp
4509 pk = registerRep register
4511 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4512 code__2 dst = code `snocOL` opc src dst
4514 returnNat (Any IntRep code__2)
4517 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4518 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4520 #endif /* i386_TARGET_ARCH */
4522 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4524 #if sparc_TARGET_ARCH
4527 = getRegister x `thenNat` \ register ->
4528 getNewRegNCG IntRep `thenNat` \ reg ->
4530 code = registerCode register reg
4531 src = registerName register reg
4533 code__2 dst = code `appOL` toOL [
4534 ST W src (spRel (-2)),
4535 LD W (spRel (-2)) dst,
4536 FxTOy W (primRepToSize pk) dst dst]
4538 returnNat (Any pk code__2)
4541 coerceFP2Int fprep x
4542 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4543 getRegister x `thenNat` \ register ->
4544 getNewRegNCG fprep `thenNat` \ reg ->
4545 getNewRegNCG FloatRep `thenNat` \ tmp ->
4547 code = registerCode register reg
4548 src = registerName register reg
4549 code__2 dst = code `appOL` toOL [
4550 FxTOy (primRepToSize fprep) W src tmp,
4551 ST W tmp (spRel (-2)),
4552 LD W (spRel (-2)) dst]
4554 returnNat (Any IntRep code__2)
4558 = getRegister x `thenNat` \ register ->
4559 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4560 let code = registerCode register tmp
4561 src = registerName register tmp
4563 returnNat (Any FloatRep
4564 (\dst -> code `snocOL` FxTOy DF F src dst))
4568 = getRegister x `thenNat` \ register ->
4569 getNewRegNCG FloatRep `thenNat` \ tmp ->
4570 let code = registerCode register tmp
4571 src = registerName register tmp
4573 returnNat (Any DoubleRep
4574 (\dst -> code `snocOL` FxTOy F DF src dst))
4576 #endif /* sparc_TARGET_ARCH */
4578 #if powerpc_TARGET_ARCH
4580 = ASSERT(pk == DoubleRep)
4581 getRegister x `thenNat` \ register ->
4582 getNewRegNCG IntRep `thenNat` \ reg ->
4583 getNatLabelNCG `thenNat` \ lbl ->
4584 getNewRegNCG PtrRep `thenNat` \ itmp ->
4585 getNewRegNCG DoubleRep `thenNat` \ ftmp ->
4587 code = registerCode register reg
4588 src = registerName register reg
4589 code__2 dst = code `appOL` toOL [
4590 SEGMENT RoDataSegment,
4592 DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
4593 SEGMENT TextSegment,
4594 XORIS itmp src (ImmInt 0x8000),
4595 ST W itmp (spRel (-1)),
4596 LIS itmp (ImmInt 0x4330),
4597 ST W itmp (spRel (-2)),
4598 LD DF ftmp (spRel (-2)),
4599 LIS itmp (HA (ImmCLbl lbl)),
4600 LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
4601 FSUB DF dst ftmp dst
4604 returnNat (Any DoubleRep code__2)
4606 coerceFP2Int fprep x
4607 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4608 getRegister x `thenNat` \ register ->
4609 getNewRegNCG fprep `thenNat` \ reg ->
4610 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4612 code = registerCode register reg
4613 src = registerName register reg
4614 code__2 dst = code `appOL` toOL [
4615 -- convert to int in FP reg
4617 -- store value (64bit) from FP to stack
4618 ST DF tmp (spRel (-2)),
4619 -- read low word of value (high word is undefined)
4620 LD W dst (spRel (-1))]
4622 returnNat (Any IntRep code__2)
4623 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4624 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4625 #endif /* powerpc_TARGET_ARCH */
4627 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -