2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[MachCode]{Generating machine code}
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import Unique ( Unique )
18 import MachMisc -- may differ per-platform
20 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
21 snocOL, consOL, concatOL )
22 import MachOp ( MachOp(..), pprMachOp )
23 import AbsCUtils ( magicIdPrimRep )
24 import PprAbsC ( pprMagicId )
25 import ForeignCall ( CCallConv(..) )
26 import CLabel ( CLabel, labelDynamic )
27 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
28 import CLabel ( isAsmTemp )
30 import Maybes ( maybeToBool )
31 import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
32 #if powerpc_TARGET_ARCH
35 getPrimRepSizeInBytes )
36 import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
37 StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
38 DestInfo, hasDestInfo,
39 pprStixExpr, repOfStixExpr,
41 NatM, thenNat, returnNat, mapNat,
42 mapAndUnzipNat, mapAccumLNat,
43 getDeltaNat, setDeltaNat, getUniqueNat,
44 IF_OS_darwin(addImportNat COMMA,)
49 import Outputable ( panic, pprPanic, showSDoc )
50 import qualified Outputable
51 import CmdLineOpts ( opt_Static )
52 import Stix ( pprStixStmt )
55 import Outputable ( assertPanic )
57 import TRACE ( trace )
62 @InstrBlock@s are the insn sequences generated by the insn selectors.
63 They are really trees of insns to facilitate fast appending, where a
64 left-to-right traversal (pre-order?) yields the insns in the correct
68 type InstrBlock = OrdList Instr
72 isLeft (Left _) = True
73 isLeft (Right _) = False
78 Code extractor for an entire stix tree---stix statement level.
81 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
83 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
84 returnNat (concatOL instrss)
87 stmtToInstrs :: StixStmt -> NatM InstrBlock
88 stmtToInstrs stmt = case stmt of
89 StComment s -> returnNat (unitOL (COMMENT s))
90 StSegment seg -> returnNat (unitOL (SEGMENT seg))
92 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
94 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
97 StLabel lab -> returnNat (unitOL (LABEL lab))
99 StJump dsts arg -> genJump dsts (derefDLL arg)
100 StCondJump lab arg -> genCondJump lab (derefDLL arg)
102 -- A call returning void, ie one done for its side-effects. Note
103 -- that this is the only StVoidable we handle.
104 StVoidable (StCall fn cconv VoidRep args)
105 -> genCCall fn cconv VoidRep (map derefDLL args)
107 StAssignMem pk addr src
108 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
109 | ncg_target_is_32bit
110 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
111 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
112 StAssignReg pk reg src
113 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
114 | ncg_target_is_32bit
115 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
116 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
119 -- When falling through on the Alpha, we still have to load pv
120 -- with the address of the next routine, so that it can load gp.
121 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
125 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
126 returnNat (DATA (primRepToSize kind) imms
127 `consOL` concatOL codes)
129 getData :: StixExpr -> NatM (InstrBlock, Imm)
130 getData (StInt i) = returnNat (nilOL, ImmInteger i)
131 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
132 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
133 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
134 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
135 -- the linker can handle simple arithmetic...
136 getData (StIndex rep (StCLbl lbl) (StInt off)) =
138 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
140 -- Top-level lifted-out string. The segment will already have been set
141 -- (see Stix.liftStrings).
143 -> returnNat (unitOL (ASCII True (unpackFS str)))
146 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
149 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
150 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
151 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
153 derefDLL :: StixExpr -> StixExpr
155 | opt_Static -- short out the entire deal if not doing DLLs
162 StCLbl lbl -> if labelDynamic lbl
163 then StInd PtrRep (StCLbl lbl)
165 -- all the rest are boring
166 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
167 StMachOp mop args -> StMachOp mop (map qq args)
168 StInd pk addr -> StInd pk (qq addr)
169 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
170 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
176 _ -> pprPanic "derefDLL: unhandled case"
180 %************************************************************************
182 \subsection{General things for putting together code sequences}
184 %************************************************************************
187 mangleIndexTree :: StixExpr -> StixExpr
189 mangleIndexTree (StIndex pk base (StInt i))
190 = StMachOp MO_Nat_Add [base, off]
192 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
194 mangleIndexTree (StIndex pk base off)
195 = StMachOp MO_Nat_Add [
198 in if s == 0 then off
199 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
202 shift :: PrimRep -> Int
203 shift rep = case getPrimRepSizeInBytes rep of
208 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
209 (Outputable.int other)
213 maybeImm :: StixExpr -> Maybe Imm
217 maybeImm (StIndex rep (StCLbl l) (StInt off))
218 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
220 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
221 = Just (ImmInt (fromInteger i))
223 = Just (ImmInteger i)
228 %************************************************************************
230 \subsection{The @Register64@ type}
232 %************************************************************************
234 Simple support for generating 64-bit code (ie, 64 bit values and 64
235 bit assignments) on 32-bit platforms. Unlike the main code generator
236 we merely shoot for generating working code as simply as possible, and
237 pay little attention to code quality. Specifically, there is no
238 attempt to deal cleverly with the fixed-vs-floating register
239 distinction; all values are generated into (pairs of) floating
240 registers, even if this would mean some redundant reg-reg moves as a
241 result. Only one of the VRegUniques is returned, since it will be
242 of the VRegUniqueLo form, and the upper-half VReg can be determined
243 by applying getHiVRegFromLo to it.
247 data ChildCode64 -- a.k.a "Register64"
250 VRegUnique -- unique for the lower 32-bit temporary
251 -- which contains the result; use getHiVRegFromLo to find
252 -- the other VRegUnique.
253 -- Rules of this simplified insn selection game are
254 -- therefore that the returned VRegUnique may be modified
256 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
257 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
258 iselExpr64 :: StixExpr -> NatM ChildCode64
260 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
264 assignMem_I64Code addrTree valueTree
265 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
266 getRegister addrTree `thenNat` \ register_addr ->
267 getNewRegNCG IntRep `thenNat` \ t_addr ->
268 let rlo = VirtualRegI vrlo
269 rhi = getHiVRegFromLo rlo
270 code_addr = registerCode register_addr t_addr
271 reg_addr = registerName register_addr t_addr
272 -- Little-endian store
273 mov_lo = MOV L (OpReg rlo)
274 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
275 mov_hi = MOV L (OpReg rhi)
276 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
278 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
280 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
281 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
283 r_dst_lo = mkVReg u_dst IntRep
284 r_src_lo = VirtualRegI vr_src_lo
285 r_dst_hi = getHiVRegFromLo r_dst_lo
286 r_src_hi = getHiVRegFromLo r_src_lo
287 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
288 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
291 vcode `snocOL` mov_lo `snocOL` mov_hi
294 assignReg_I64Code lvalue valueTree
295 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
300 iselExpr64 (StInd pk addrTree)
302 = getRegister addrTree `thenNat` \ register_addr ->
303 getNewRegNCG IntRep `thenNat` \ t_addr ->
304 getNewRegNCG IntRep `thenNat` \ rlo ->
305 let rhi = getHiVRegFromLo rlo
306 code_addr = registerCode register_addr t_addr
307 reg_addr = registerName register_addr t_addr
308 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
310 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
314 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
318 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
320 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
321 let r_dst_hi = getHiVRegFromLo r_dst_lo
322 r_src_lo = mkVReg vu IntRep
323 r_src_hi = getHiVRegFromLo r_src_lo
324 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
325 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
328 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
331 iselExpr64 (StCall fn cconv kind args)
333 = genCCall fn cconv kind args `thenNat` \ call ->
334 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
335 let r_dst_hi = getHiVRegFromLo r_dst_lo
336 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
337 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
340 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
341 (getVRegUnique r_dst_lo)
345 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
347 #endif {- i386_TARGET_ARCH -}
349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
351 #if sparc_TARGET_ARCH
353 assignMem_I64Code addrTree valueTree
354 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
355 getRegister addrTree `thenNat` \ register_addr ->
356 getNewRegNCG IntRep `thenNat` \ t_addr ->
357 let rlo = VirtualRegI vrlo
358 rhi = getHiVRegFromLo rlo
359 code_addr = registerCode register_addr t_addr
360 reg_addr = registerName register_addr t_addr
362 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
363 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
365 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
368 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
369 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
371 r_dst_lo = mkVReg u_dst IntRep
372 r_src_lo = VirtualRegI vr_src_lo
373 r_dst_hi = getHiVRegFromLo r_dst_lo
374 r_src_hi = getHiVRegFromLo r_src_lo
375 mov_lo = mkMOV r_src_lo r_dst_lo
376 mov_hi = mkMOV r_src_hi r_dst_hi
377 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
380 vcode `snocOL` mov_hi `snocOL` mov_lo
382 assignReg_I64Code lvalue valueTree
383 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
387 -- Don't delete this -- it's very handy for debugging.
389 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
390 -- = panic "iselExpr64(???)"
392 iselExpr64 (StInd pk addrTree)
394 = getRegister addrTree `thenNat` \ register_addr ->
395 getNewRegNCG IntRep `thenNat` \ t_addr ->
396 getNewRegNCG IntRep `thenNat` \ rlo ->
397 let rhi = getHiVRegFromLo rlo
398 code_addr = registerCode register_addr t_addr
399 reg_addr = registerName register_addr t_addr
400 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
401 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
404 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
408 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
410 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
411 let r_dst_hi = getHiVRegFromLo r_dst_lo
412 r_src_lo = mkVReg vu IntRep
413 r_src_hi = getHiVRegFromLo r_src_lo
414 mov_lo = mkMOV r_src_lo r_dst_lo
415 mov_hi = mkMOV r_src_hi r_dst_hi
416 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
419 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
422 iselExpr64 (StCall fn cconv kind args)
424 = genCCall fn cconv kind args `thenNat` \ call ->
425 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
426 let r_dst_hi = getHiVRegFromLo r_dst_lo
427 mov_lo = mkMOV o0 r_dst_lo
428 mov_hi = mkMOV o1 r_dst_hi
429 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
432 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
433 (getVRegUnique r_dst_lo)
437 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
439 #endif {- sparc_TARGET_ARCH -}
440 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
442 #if powerpc_TARGET_ARCH
444 assignMem_I64Code addrTree valueTree
445 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
446 getRegister addrTree `thenNat` \ register_addr ->
447 getNewRegNCG IntRep `thenNat` \ t_addr ->
448 let rlo = VirtualRegI vrlo
449 rhi = getHiVRegFromLo rlo
450 code_addr = registerCode register_addr t_addr
451 reg_addr = registerName register_addr t_addr
453 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
454 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
456 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
459 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
460 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
462 r_dst_lo = mkVReg u_dst IntRep
463 r_src_lo = VirtualRegI vr_src_lo
464 r_dst_hi = getHiVRegFromLo r_dst_lo
465 r_src_hi = getHiVRegFromLo r_src_lo
466 mov_lo = MR r_dst_lo r_src_lo
467 mov_hi = MR r_dst_hi r_src_hi
470 vcode `snocOL` mov_hi `snocOL` mov_lo
472 assignReg_I64Code lvalue valueTree
473 = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
477 -- Don't delete this -- it's very handy for debugging.
479 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
480 -- = panic "iselExpr64(???)"
482 iselExpr64 (StInd pk addrTree)
484 = getRegister addrTree `thenNat` \ register_addr ->
485 getNewRegNCG IntRep `thenNat` \ t_addr ->
486 getNewRegNCG IntRep `thenNat` \ rlo ->
487 let rhi = getHiVRegFromLo rlo
488 code_addr = registerCode register_addr t_addr
489 reg_addr = registerName register_addr t_addr
490 mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
491 mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
494 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
498 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
500 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
501 let r_dst_hi = getHiVRegFromLo r_dst_lo
502 r_src_lo = mkVReg vu IntRep
503 r_src_hi = getHiVRegFromLo r_src_lo
504 mov_lo = MR r_dst_lo r_src_lo
505 mov_hi = MR r_dst_hi r_src_hi
508 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
511 iselExpr64 (StCall fn cconv kind args)
513 = genCCall fn cconv kind args `thenNat` \ call ->
514 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
515 let r_dst_hi = getHiVRegFromLo r_dst_lo
516 mov_lo = MR r_dst_lo r4
517 mov_hi = MR r_dst_hi r3
520 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
521 (getVRegUnique r_dst_lo)
525 = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
527 #endif {- powerpc_TARGET_ARCH -}
529 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
533 %************************************************************************
535 \subsection{The @Register@ type}
537 %************************************************************************
539 @Register@s passed up the tree. If the stix code forces the register
540 to live in a pre-decided machine register, it comes out as @Fixed@;
541 otherwise, it comes out as @Any@, and the parent can decide which
542 register to put it in.
546 = Fixed PrimRep Reg InstrBlock
547 | Any PrimRep (Reg -> InstrBlock)
549 registerCode :: Register -> Reg -> InstrBlock
550 registerCode (Fixed _ _ code) reg = code
551 registerCode (Any _ code) reg = code reg
553 registerCodeF (Fixed _ _ code) = code
554 registerCodeF (Any _ _) = panic "registerCodeF"
556 registerCodeA (Any _ code) = code
557 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
559 registerName :: Register -> Reg -> Reg
560 registerName (Fixed _ reg _) _ = reg
561 registerName (Any _ _) reg = reg
563 registerNameF (Fixed _ reg _) = reg
564 registerNameF (Any _ _) = panic "registerNameF"
566 registerRep :: Register -> PrimRep
567 registerRep (Fixed pk _ _) = pk
568 registerRep (Any pk _) = pk
570 swizzleRegisterRep :: Register -> PrimRep -> Register
571 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
572 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
574 {-# INLINE registerCode #-}
575 {-# INLINE registerCodeF #-}
576 {-# INLINE registerName #-}
577 {-# INLINE registerNameF #-}
578 {-# INLINE registerRep #-}
579 {-# INLINE isFixed #-}
582 isFixed, isAny :: Register -> Bool
583 isFixed (Fixed _ _ _) = True
584 isFixed (Any _ _) = False
586 isAny = not . isFixed
589 Generate code to get a subtree into a @Register@:
592 getRegisterReg :: StixReg -> NatM Register
593 getRegister :: StixExpr -> NatM Register
596 getRegisterReg (StixMagicId mid)
597 = case get_MagicId_reg_or_addr mid of
599 -> let pk = magicIdPrimRep mid
600 in returnNat (Fixed pk (RealReg rrno) nilOL)
602 -- By this stage, the only MagicIds remaining should be the
603 -- ones which map to a real machine register on this platform. Hence ...
604 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
606 getRegisterReg (StixTemp (StixVReg u pk))
607 = returnNat (Fixed pk (mkVReg u pk) nilOL)
611 -- Don't delete this -- it's very handy for debugging.
613 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
614 -- = panic "getRegister(???)"
616 getRegister (StReg reg)
619 getRegister tree@(StIndex _ _ _)
620 = getRegister (mangleIndexTree tree)
622 getRegister (StCall fn cconv kind args)
623 | not (ncg_target_is_32bit && is64BitRep kind)
624 = genCCall fn cconv kind args `thenNat` \ call ->
625 returnNat (Fixed kind reg call)
627 reg = if isFloatingRep kind
628 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
629 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
631 getRegister (StString s)
632 = getNatLabelNCG `thenNat` \ lbl ->
634 imm_lbl = ImmCLbl lbl
637 SEGMENT RoDataSegment,
639 ASCII True (unpackFS s),
641 #if alpha_TARGET_ARCH
642 LDA dst (AddrImm imm_lbl)
645 MOV L (OpImm imm_lbl) (OpReg dst)
647 #if sparc_TARGET_ARCH
648 SETHI (HI imm_lbl) dst,
649 OR False dst (RIImm (LO imm_lbl)) dst
651 #if powerpc_TARGET_ARCH
652 LIS dst (HI imm_lbl),
653 OR dst dst (RIImm (LO imm_lbl))
657 returnNat (Any PtrRep code)
659 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
660 -- end of machine-"independent" bit; here we go on the rest...
662 #if alpha_TARGET_ARCH
664 getRegister (StDouble d)
665 = getNatLabelNCG `thenNat` \ lbl ->
666 getNewRegNCG PtrRep `thenNat` \ tmp ->
667 let code dst = mkSeqInstrs [
670 DATA TF [ImmLab (rational d)],
672 LDA tmp (AddrImm (ImmCLbl lbl)),
673 LD TF dst (AddrReg tmp)]
675 returnNat (Any DoubleRep code)
677 getRegister (StPrim primop [x]) -- unary PrimOps
679 IntNegOp -> trivialUCode (NEG Q False) x
681 NotOp -> trivialUCode NOT x
683 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
684 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
686 OrdOp -> coerceIntCode IntRep x
689 Float2IntOp -> coerceFP2Int x
690 Int2FloatOp -> coerceInt2FP pr x
691 Double2IntOp -> coerceFP2Int x
692 Int2DoubleOp -> coerceInt2FP pr x
694 Double2FloatOp -> coerceFltCode x
695 Float2DoubleOp -> coerceFltCode x
697 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
699 fn = case other_op of
700 FloatExpOp -> FSLIT("exp")
701 FloatLogOp -> FSLIT("log")
702 FloatSqrtOp -> FSLIT("sqrt")
703 FloatSinOp -> FSLIT("sin")
704 FloatCosOp -> FSLIT("cos")
705 FloatTanOp -> FSLIT("tan")
706 FloatAsinOp -> FSLIT("asin")
707 FloatAcosOp -> FSLIT("acos")
708 FloatAtanOp -> FSLIT("atan")
709 FloatSinhOp -> FSLIT("sinh")
710 FloatCoshOp -> FSLIT("cosh")
711 FloatTanhOp -> FSLIT("tanh")
712 DoubleExpOp -> FSLIT("exp")
713 DoubleLogOp -> FSLIT("log")
714 DoubleSqrtOp -> FSLIT("sqrt")
715 DoubleSinOp -> FSLIT("sin")
716 DoubleCosOp -> FSLIT("cos")
717 DoubleTanOp -> FSLIT("tan")
718 DoubleAsinOp -> FSLIT("asin")
719 DoubleAcosOp -> FSLIT("acos")
720 DoubleAtanOp -> FSLIT("atan")
721 DoubleSinhOp -> FSLIT("sinh")
722 DoubleCoshOp -> FSLIT("cosh")
723 DoubleTanhOp -> FSLIT("tanh")
725 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
727 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
729 CharGtOp -> trivialCode (CMP LTT) y x
730 CharGeOp -> trivialCode (CMP LE) y x
731 CharEqOp -> trivialCode (CMP EQQ) x y
732 CharNeOp -> int_NE_code x y
733 CharLtOp -> trivialCode (CMP LTT) x y
734 CharLeOp -> trivialCode (CMP LE) x y
736 IntGtOp -> trivialCode (CMP LTT) y x
737 IntGeOp -> trivialCode (CMP LE) y x
738 IntEqOp -> trivialCode (CMP EQQ) x y
739 IntNeOp -> int_NE_code x y
740 IntLtOp -> trivialCode (CMP LTT) x y
741 IntLeOp -> trivialCode (CMP LE) x y
743 WordGtOp -> trivialCode (CMP ULT) y x
744 WordGeOp -> trivialCode (CMP ULE) x y
745 WordEqOp -> trivialCode (CMP EQQ) x y
746 WordNeOp -> int_NE_code x y
747 WordLtOp -> trivialCode (CMP ULT) x y
748 WordLeOp -> trivialCode (CMP ULE) x y
750 AddrGtOp -> trivialCode (CMP ULT) y x
751 AddrGeOp -> trivialCode (CMP ULE) y x
752 AddrEqOp -> trivialCode (CMP EQQ) x y
753 AddrNeOp -> int_NE_code x y
754 AddrLtOp -> trivialCode (CMP ULT) x y
755 AddrLeOp -> trivialCode (CMP ULE) x y
757 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
758 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
759 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
760 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
761 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
762 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
764 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
765 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
766 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
767 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
768 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
769 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
771 IntAddOp -> trivialCode (ADD Q False) x y
772 IntSubOp -> trivialCode (SUB Q False) x y
773 IntMulOp -> trivialCode (MUL Q False) x y
774 IntQuotOp -> trivialCode (DIV Q False) x y
775 IntRemOp -> trivialCode (REM Q False) x y
777 WordAddOp -> trivialCode (ADD Q False) x y
778 WordSubOp -> trivialCode (SUB Q False) x y
779 WordMulOp -> trivialCode (MUL Q False) x y
780 WordQuotOp -> trivialCode (DIV Q True) x y
781 WordRemOp -> trivialCode (REM Q True) x y
783 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
784 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
785 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
786 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
788 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
789 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
790 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
791 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
793 AddrAddOp -> trivialCode (ADD Q False) x y
794 AddrSubOp -> trivialCode (SUB Q False) x y
795 AddrRemOp -> trivialCode (REM Q True) x y
797 AndOp -> trivialCode AND x y
798 OrOp -> trivialCode OR x y
799 XorOp -> trivialCode XOR x y
800 SllOp -> trivialCode SLL x y
801 SrlOp -> trivialCode SRL x y
803 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
804 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
805 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
807 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
808 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
810 {- ------------------------------------------------------------
811 Some bizarre special code for getting condition codes into
812 registers. Integer non-equality is a test for equality
813 followed by an XOR with 1. (Integer comparisons always set
814 the result register to 0 or 1.) Floating point comparisons of
815 any kind leave the result in a floating point register, so we
816 need to wrangle an integer register out of things.
818 int_NE_code :: StixTree -> StixTree -> NatM Register
821 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
822 getNewRegNCG IntRep `thenNat` \ tmp ->
824 code = registerCode register tmp
825 src = registerName register tmp
826 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
828 returnNat (Any IntRep code__2)
830 {- ------------------------------------------------------------
831 Comments for int_NE_code also apply to cmpF_code
834 :: (Reg -> Reg -> Reg -> Instr)
836 -> StixTree -> StixTree
839 cmpF_code instr cond x y
840 = trivialFCode pr instr x y `thenNat` \ register ->
841 getNewRegNCG DoubleRep `thenNat` \ tmp ->
842 getNatLabelNCG `thenNat` \ lbl ->
844 code = registerCode register tmp
845 result = registerName register tmp
847 code__2 dst = code . mkSeqInstrs [
848 OR zeroh (RIImm (ImmInt 1)) dst,
849 BF cond result (ImmCLbl lbl),
850 OR zeroh (RIReg zeroh) dst,
853 returnNat (Any IntRep code__2)
855 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
856 ------------------------------------------------------------
858 getRegister (StInd pk mem)
859 = getAmode mem `thenNat` \ amode ->
861 code = amodeCode amode
862 src = amodeAddr amode
863 size = primRepToSize pk
864 code__2 dst = code . mkSeqInstr (LD size dst src)
866 returnNat (Any pk code__2)
868 getRegister (StInt i)
871 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
873 returnNat (Any IntRep code)
876 code dst = mkSeqInstr (LDI Q dst src)
878 returnNat (Any IntRep code)
880 src = ImmInt (fromInteger i)
885 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
887 returnNat (Any PtrRep code)
890 imm__2 = case imm of Just x -> x
892 #endif {- alpha_TARGET_ARCH -}
894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
898 getRegister (StFloat f)
899 = getNatLabelNCG `thenNat` \ lbl ->
900 let code dst = toOL [
905 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
908 returnNat (Any FloatRep code)
911 getRegister (StDouble d)
914 = let code dst = unitOL (GLDZ dst)
915 in returnNat (Any DoubleRep code)
918 = let code dst = unitOL (GLD1 dst)
919 in returnNat (Any DoubleRep code)
922 = getNatLabelNCG `thenNat` \ lbl ->
923 let code dst = toOL [
926 DATA DF [ImmDouble d],
928 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
931 returnNat (Any DoubleRep code)
934 getRegister (StMachOp mop [x]) -- unary MachOps
936 MO_NatS_Neg -> trivialUCode (NEGI L) x
937 MO_Nat_Not -> trivialUCode (NOT L) x
938 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
940 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
941 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
943 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
944 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
946 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
947 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
949 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
950 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
952 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
953 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
955 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
956 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
957 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
958 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
960 -- Conversions which are a nop on x86
961 MO_32U_to_NatS -> conversionNop IntRep x
962 MO_32S_to_NatS -> conversionNop IntRep x
963 MO_NatS_to_32U -> conversionNop WordRep x
964 MO_32U_to_NatU -> conversionNop WordRep x
966 MO_NatU_to_NatS -> conversionNop IntRep x
967 MO_NatS_to_NatU -> conversionNop WordRep x
968 MO_NatP_to_NatU -> conversionNop WordRep x
969 MO_NatU_to_NatP -> conversionNop PtrRep x
970 MO_NatS_to_NatP -> conversionNop PtrRep x
971 MO_NatP_to_NatS -> conversionNop IntRep x
973 MO_Dbl_to_Flt -> conversionNop FloatRep x
974 MO_Flt_to_Dbl -> conversionNop DoubleRep x
976 -- sign-extending widenings
977 MO_8U_to_NatU -> integerExtend False 24 x
978 MO_8S_to_NatS -> integerExtend True 24 x
979 MO_16U_to_NatU -> integerExtend False 16 x
980 MO_16S_to_NatS -> integerExtend True 16 x
981 MO_8U_to_32U -> integerExtend False 24 x
985 (if is_float_op then demote else id)
986 (StCall (Left fn) CCallConv DoubleRep
987 [(if is_float_op then promote else id) x])
990 integerExtend signed nBits x
992 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
993 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
996 conversionNop new_rep expr
997 = getRegister expr `thenNat` \ e_code ->
998 returnNat (swizzleRegisterRep e_code new_rep)
1000 promote x = StMachOp MO_Flt_to_Dbl [x]
1001 demote x = StMachOp MO_Dbl_to_Flt [x]
1004 MO_Flt_Exp -> (True, FSLIT("exp"))
1005 MO_Flt_Log -> (True, FSLIT("log"))
1007 MO_Flt_Asin -> (True, FSLIT("asin"))
1008 MO_Flt_Acos -> (True, FSLIT("acos"))
1009 MO_Flt_Atan -> (True, FSLIT("atan"))
1011 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1012 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1013 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1015 MO_Dbl_Exp -> (False, FSLIT("exp"))
1016 MO_Dbl_Log -> (False, FSLIT("log"))
1018 MO_Dbl_Asin -> (False, FSLIT("asin"))
1019 MO_Dbl_Acos -> (False, FSLIT("acos"))
1020 MO_Dbl_Atan -> (False, FSLIT("atan"))
1022 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1023 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1024 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1026 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
1030 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
1032 MO_32U_Gt -> condIntReg GTT x y
1033 MO_32U_Ge -> condIntReg GE x y
1034 MO_32U_Eq -> condIntReg EQQ x y
1035 MO_32U_Ne -> condIntReg NE x y
1036 MO_32U_Lt -> condIntReg LTT x y
1037 MO_32U_Le -> condIntReg LE x y
1039 MO_Nat_Eq -> condIntReg EQQ x y
1040 MO_Nat_Ne -> condIntReg NE x y
1042 MO_NatS_Gt -> condIntReg GTT x y
1043 MO_NatS_Ge -> condIntReg GE x y
1044 MO_NatS_Lt -> condIntReg LTT x y
1045 MO_NatS_Le -> condIntReg LE x y
1047 MO_NatU_Gt -> condIntReg GU x y
1048 MO_NatU_Ge -> condIntReg GEU x y
1049 MO_NatU_Lt -> condIntReg LU x y
1050 MO_NatU_Le -> condIntReg LEU x y
1052 MO_Flt_Gt -> condFltReg GTT x y
1053 MO_Flt_Ge -> condFltReg GE x y
1054 MO_Flt_Eq -> condFltReg EQQ x y
1055 MO_Flt_Ne -> condFltReg NE x y
1056 MO_Flt_Lt -> condFltReg LTT x y
1057 MO_Flt_Le -> condFltReg LE x y
1059 MO_Dbl_Gt -> condFltReg GTT x y
1060 MO_Dbl_Ge -> condFltReg GE x y
1061 MO_Dbl_Eq -> condFltReg EQQ x y
1062 MO_Dbl_Ne -> condFltReg NE x y
1063 MO_Dbl_Lt -> condFltReg LTT x y
1064 MO_Dbl_Le -> condFltReg LE x y
1066 MO_Nat_Add -> add_code L x y
1067 MO_Nat_Sub -> sub_code L x y
1068 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
1069 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
1070 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
1071 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
1072 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
1073 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
1074 MO_NatS_MulMayOflo -> imulMayOflo x y
1076 MO_Flt_Add -> trivialFCode FloatRep GADD x y
1077 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
1078 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
1079 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
1081 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
1082 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
1083 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
1084 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
1086 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
1087 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
1088 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1090 {- Shift ops on x86s have constraints on their source, it
1091 either has to be Imm, CL or 1
1092 => trivialCode's is not restrictive enough (sigh.)
1094 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
1095 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1096 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1098 MO_Flt_Pwr -> getRegister (demote
1099 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1100 [promote x, promote y])
1102 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1104 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1106 promote x = StMachOp MO_Flt_to_Dbl [x]
1107 demote x = StMachOp MO_Dbl_to_Flt [x]
1109 --------------------
1110 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1112 = getNewRegNCG IntRep `thenNat` \ t1 ->
1113 getNewRegNCG IntRep `thenNat` \ t2 ->
1114 getNewRegNCG IntRep `thenNat` \ res_lo ->
1115 getNewRegNCG IntRep `thenNat` \ res_hi ->
1116 getRegister a1 `thenNat` \ reg1 ->
1117 getRegister a2 `thenNat` \ reg2 ->
1118 let code1 = registerCode reg1 t1
1119 code2 = registerCode reg2 t2
1120 src1 = registerName reg1 t1
1121 src2 = registerName reg2 t2
1122 code dst = code1 `appOL` code2 `appOL`
1124 MOV L (OpReg src1) (OpReg res_hi),
1125 MOV L (OpReg src2) (OpReg res_lo),
1126 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1127 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1128 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1129 MOV L (OpReg res_lo) (OpReg dst)
1130 -- dst==0 if high part == sign extended low part
1133 returnNat (Any IntRep code)
1135 --------------------
1136 shift_code :: (Imm -> Operand -> Instr)
1141 {- Case1: shift length as immediate -}
1142 -- Code is the same as the first eq. for trivialCode -- sigh.
1143 shift_code instr x y{-amount-}
1145 = getRegister x `thenNat` \ regx ->
1148 then registerCodeA regx dst `bind` \ code_x ->
1150 instr imm__2 (OpReg dst)
1151 else registerCodeF regx `bind` \ code_x ->
1152 registerNameF regx `bind` \ r_x ->
1154 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1155 instr imm__2 (OpReg dst)
1157 returnNat (Any IntRep mkcode)
1160 imm__2 = case imm of Just x -> x
1162 {- Case2: shift length is complex (non-immediate) -}
1163 -- Since ECX is always used as a spill temporary, we can't
1164 -- use it here to do non-immediate shifts. No big deal --
1165 -- they are only very rare, and we can use an equivalent
1166 -- test-and-jump sequence which doesn't use ECX.
1167 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1168 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1169 shift_code instr x y{-amount-}
1170 = getRegister x `thenNat` \ register1 ->
1171 getRegister y `thenNat` \ register2 ->
1172 getNatLabelNCG `thenNat` \ lbl_test3 ->
1173 getNatLabelNCG `thenNat` \ lbl_test2 ->
1174 getNatLabelNCG `thenNat` \ lbl_test1 ->
1175 getNatLabelNCG `thenNat` \ lbl_test0 ->
1176 getNatLabelNCG `thenNat` \ lbl_after ->
1177 getNewRegNCG IntRep `thenNat` \ tmp ->
1179 = let src_val = registerName register1 dst
1180 code_val = registerCode register1 dst
1181 src_amt = registerName register2 tmp
1182 code_amt = registerCode register2 tmp
1187 MOV L (OpReg src_amt) r_tmp `appOL`
1189 MOV L (OpReg src_val) r_dst `appOL`
1191 COMMENT (mkFastString "begin shift sequence"),
1192 MOV L (OpReg src_val) r_dst,
1193 MOV L (OpReg src_amt) r_tmp,
1195 BT L (ImmInt 4) r_tmp,
1197 instr (ImmInt 16) r_dst,
1200 BT L (ImmInt 3) r_tmp,
1202 instr (ImmInt 8) r_dst,
1205 BT L (ImmInt 2) r_tmp,
1207 instr (ImmInt 4) r_dst,
1210 BT L (ImmInt 1) r_tmp,
1212 instr (ImmInt 2) r_dst,
1215 BT L (ImmInt 0) r_tmp,
1217 instr (ImmInt 1) r_dst,
1220 COMMENT (mkFastString "end shift sequence")
1223 returnNat (Any IntRep code__2)
1225 --------------------
1226 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1228 add_code sz x (StInt y)
1229 = getRegister x `thenNat` \ register ->
1230 getNewRegNCG IntRep `thenNat` \ tmp ->
1232 code = registerCode register tmp
1233 src1 = registerName register tmp
1234 src2 = ImmInt (fromInteger y)
1237 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1240 returnNat (Any IntRep code__2)
1242 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1244 --------------------
1245 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1247 sub_code sz x (StInt y)
1248 = getRegister x `thenNat` \ register ->
1249 getNewRegNCG IntRep `thenNat` \ tmp ->
1251 code = registerCode register tmp
1252 src1 = registerName register tmp
1253 src2 = ImmInt (-(fromInteger y))
1256 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1259 returnNat (Any IntRep code__2)
1261 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1263 getRegister (StInd pk mem)
1264 | not (is64BitRep pk)
1265 = getAmode mem `thenNat` \ amode ->
1267 code = amodeCode amode
1268 src = amodeAddr amode
1269 size = primRepToSize pk
1270 code__2 dst = code `snocOL`
1271 if pk == DoubleRep || pk == FloatRep
1272 then GLD size src dst
1280 (OpAddr src) (OpReg dst)
1282 returnNat (Any pk code__2)
1284 getRegister (StInt i)
1286 src = ImmInt (fromInteger i)
1289 = unitOL (XOR L (OpReg dst) (OpReg dst))
1291 = unitOL (MOV L (OpImm src) (OpReg dst))
1293 returnNat (Any IntRep code)
1297 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1299 returnNat (Any PtrRep code)
1301 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1304 imm__2 = case imm of Just x -> x
1306 #endif {- i386_TARGET_ARCH -}
1308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1310 #if sparc_TARGET_ARCH
1312 getRegister (StFloat d)
1313 = getNatLabelNCG `thenNat` \ lbl ->
1314 getNewRegNCG PtrRep `thenNat` \ tmp ->
1315 let code dst = toOL [
1316 SEGMENT DataSegment,
1318 DATA F [ImmFloat d],
1319 SEGMENT TextSegment,
1320 SETHI (HI (ImmCLbl lbl)) tmp,
1321 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1323 returnNat (Any FloatRep code)
1325 getRegister (StDouble d)
1326 = getNatLabelNCG `thenNat` \ lbl ->
1327 getNewRegNCG PtrRep `thenNat` \ tmp ->
1328 let code dst = toOL [
1329 SEGMENT DataSegment,
1331 DATA DF [ImmDouble d],
1332 SEGMENT TextSegment,
1333 SETHI (HI (ImmCLbl lbl)) tmp,
1334 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1336 returnNat (Any DoubleRep code)
1339 getRegister (StMachOp mop [x]) -- unary PrimOps
1341 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1342 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1343 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1345 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1346 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1348 MO_Dbl_to_Flt -> coerceDbl2Flt x
1349 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1351 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1352 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1353 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1354 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1356 -- Conversions which are a nop on sparc
1357 MO_32U_to_NatS -> conversionNop IntRep x
1358 MO_32S_to_NatS -> conversionNop IntRep x
1359 MO_NatS_to_32U -> conversionNop WordRep x
1360 MO_32U_to_NatU -> conversionNop WordRep x
1362 MO_NatU_to_NatS -> conversionNop IntRep x
1363 MO_NatS_to_NatU -> conversionNop WordRep x
1364 MO_NatP_to_NatU -> conversionNop WordRep x
1365 MO_NatU_to_NatP -> conversionNop PtrRep x
1366 MO_NatS_to_NatP -> conversionNop PtrRep x
1367 MO_NatP_to_NatS -> conversionNop IntRep x
1369 -- sign-extending widenings
1370 MO_8U_to_32U -> integerExtend False 24 x
1371 MO_8U_to_NatU -> integerExtend False 24 x
1372 MO_8S_to_NatS -> integerExtend True 24 x
1373 MO_16U_to_NatU -> integerExtend False 16 x
1374 MO_16S_to_NatS -> integerExtend True 16 x
1377 let fixed_x = if is_float_op -- promote to double
1378 then StMachOp MO_Flt_to_Dbl [x]
1381 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1383 integerExtend signed nBits x
1385 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1386 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1388 conversionNop new_rep expr
1389 = getRegister expr `thenNat` \ e_code ->
1390 returnNat (swizzleRegisterRep e_code new_rep)
1394 MO_Flt_Exp -> (True, FSLIT("exp"))
1395 MO_Flt_Log -> (True, FSLIT("log"))
1396 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1398 MO_Flt_Sin -> (True, FSLIT("sin"))
1399 MO_Flt_Cos -> (True, FSLIT("cos"))
1400 MO_Flt_Tan -> (True, FSLIT("tan"))
1402 MO_Flt_Asin -> (True, FSLIT("asin"))
1403 MO_Flt_Acos -> (True, FSLIT("acos"))
1404 MO_Flt_Atan -> (True, FSLIT("atan"))
1406 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1407 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1408 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1410 MO_Dbl_Exp -> (False, FSLIT("exp"))
1411 MO_Dbl_Log -> (False, FSLIT("log"))
1412 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1414 MO_Dbl_Sin -> (False, FSLIT("sin"))
1415 MO_Dbl_Cos -> (False, FSLIT("cos"))
1416 MO_Dbl_Tan -> (False, FSLIT("tan"))
1418 MO_Dbl_Asin -> (False, FSLIT("asin"))
1419 MO_Dbl_Acos -> (False, FSLIT("acos"))
1420 MO_Dbl_Atan -> (False, FSLIT("atan"))
1422 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1423 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1424 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1426 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1430 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1432 MO_32U_Gt -> condIntReg GTT x y
1433 MO_32U_Ge -> condIntReg GE x y
1434 MO_32U_Eq -> condIntReg EQQ x y
1435 MO_32U_Ne -> condIntReg NE x y
1436 MO_32U_Lt -> condIntReg LTT x y
1437 MO_32U_Le -> condIntReg LE x y
1439 MO_Nat_Eq -> condIntReg EQQ x y
1440 MO_Nat_Ne -> condIntReg NE x y
1442 MO_NatS_Gt -> condIntReg GTT x y
1443 MO_NatS_Ge -> condIntReg GE x y
1444 MO_NatS_Lt -> condIntReg LTT x y
1445 MO_NatS_Le -> condIntReg LE x y
1447 MO_NatU_Gt -> condIntReg GU x y
1448 MO_NatU_Ge -> condIntReg GEU x y
1449 MO_NatU_Lt -> condIntReg LU x y
1450 MO_NatU_Le -> condIntReg LEU x y
1452 MO_Flt_Gt -> condFltReg GTT x y
1453 MO_Flt_Ge -> condFltReg GE x y
1454 MO_Flt_Eq -> condFltReg EQQ x y
1455 MO_Flt_Ne -> condFltReg NE x y
1456 MO_Flt_Lt -> condFltReg LTT x y
1457 MO_Flt_Le -> condFltReg LE x y
1459 MO_Dbl_Gt -> condFltReg GTT x y
1460 MO_Dbl_Ge -> condFltReg GE x y
1461 MO_Dbl_Eq -> condFltReg EQQ x y
1462 MO_Dbl_Ne -> condFltReg NE x y
1463 MO_Dbl_Lt -> condFltReg LTT x y
1464 MO_Dbl_Le -> condFltReg LE x y
1466 MO_Nat_Add -> trivialCode (ADD False False) x y
1467 MO_Nat_Sub -> trivialCode (SUB False False) x y
1469 MO_NatS_Mul -> trivialCode (SMUL False) x y
1470 MO_NatU_Mul -> trivialCode (UMUL False) x y
1471 MO_NatS_MulMayOflo -> imulMayOflo x y
1473 -- ToDo: teach about V8+ SPARC div instructions
1474 MO_NatS_Quot -> idiv FSLIT(".div") x y
1475 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1476 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1477 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1479 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1480 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1481 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1482 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1484 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1485 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1486 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1487 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1489 MO_Nat_And -> trivialCode (AND False) x y
1490 MO_Nat_Or -> trivialCode (OR False) x y
1491 MO_Nat_Xor -> trivialCode (XOR False) x y
1493 MO_Nat_Shl -> trivialCode SLL x y
1494 MO_Nat_Shr -> trivialCode SRL x y
1495 MO_Nat_Sar -> trivialCode SRA x y
1497 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1498 [promote x, promote y])
1499 where promote x = StMachOp MO_Flt_to_Dbl [x]
1500 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1503 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1505 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1507 --------------------
1508 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1510 = getNewRegNCG IntRep `thenNat` \ t1 ->
1511 getNewRegNCG IntRep `thenNat` \ t2 ->
1512 getNewRegNCG IntRep `thenNat` \ res_lo ->
1513 getNewRegNCG IntRep `thenNat` \ res_hi ->
1514 getRegister a1 `thenNat` \ reg1 ->
1515 getRegister a2 `thenNat` \ reg2 ->
1516 let code1 = registerCode reg1 t1
1517 code2 = registerCode reg2 t2
1518 src1 = registerName reg1 t1
1519 src2 = registerName reg2 t2
1520 code dst = code1 `appOL` code2 `appOL`
1522 SMUL False src1 (RIReg src2) res_lo,
1524 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1525 SUB False False res_lo (RIReg res_hi) dst
1528 returnNat (Any IntRep code)
1530 getRegister (StInd pk mem)
1531 = getAmode mem `thenNat` \ amode ->
1533 code = amodeCode amode
1534 src = amodeAddr amode
1535 size = primRepToSize pk
1536 code__2 dst = code `snocOL` LD size src dst
1538 returnNat (Any pk code__2)
1540 getRegister (StInt i)
1543 src = ImmInt (fromInteger i)
1544 code dst = unitOL (OR False g0 (RIImm src) dst)
1546 returnNat (Any IntRep code)
1552 SETHI (HI imm__2) dst,
1553 OR False dst (RIImm (LO imm__2)) dst]
1555 returnNat (Any PtrRep code)
1557 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1560 imm__2 = case imm of Just x -> x
1562 #endif {- sparc_TARGET_ARCH -}
1564 #if powerpc_TARGET_ARCH
1565 getRegister (StMachOp mop [x]) -- unary MachOps
1567 MO_NatS_Neg -> trivialUCode NEG x
1568 MO_Nat_Not -> trivialUCode NOT x
1569 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1571 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1572 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1573 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1574 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1576 -- Conversions which are a nop on PPC
1577 MO_NatS_to_32U -> conversionNop WordRep x
1578 MO_32U_to_NatS -> conversionNop IntRep x
1579 MO_32U_to_NatU -> conversionNop WordRep x
1581 MO_NatU_to_NatS -> conversionNop IntRep x
1582 MO_NatS_to_NatU -> conversionNop WordRep x
1583 MO_NatP_to_NatU -> conversionNop WordRep x
1584 MO_NatU_to_NatP -> conversionNop PtrRep x
1585 MO_NatS_to_NatP -> conversionNop PtrRep x
1586 MO_NatP_to_NatS -> conversionNop IntRep x
1588 MO_Dbl_to_Flt -> conversionNop FloatRep x
1589 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1591 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1592 MO_8U_to_NatU -> integerExtend False 24 x
1593 MO_8S_to_NatS -> integerExtend True 24 x
1594 MO_16U_to_NatU -> integerExtend False 16 x
1595 MO_16S_to_NatS -> integerExtend True 16 x
1596 MO_8U_to_32U -> integerExtend False 24 x
1598 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1601 integerExtend signed nBits x
1603 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1604 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1606 conversionNop new_rep expr
1607 = getRegister expr `thenNat` \ e_code ->
1608 returnNat (swizzleRegisterRep e_code new_rep)
1610 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1612 MO_32U_Gt -> condIntReg GTT x y
1613 MO_32U_Ge -> condIntReg GE x y
1614 MO_32U_Eq -> condIntReg EQQ x y
1615 MO_32U_Ne -> condIntReg NE x y
1616 MO_32U_Lt -> condIntReg LTT x y
1617 MO_32U_Le -> condIntReg LE x y
1619 MO_Nat_Eq -> condIntReg EQQ x y
1620 MO_Nat_Ne -> condIntReg NE x y
1622 MO_NatS_Gt -> condIntReg GTT x y
1623 MO_NatS_Ge -> condIntReg GE x y
1624 MO_NatS_Lt -> condIntReg LTT x y
1625 MO_NatS_Le -> condIntReg LE x y
1627 MO_NatU_Gt -> condIntReg GU x y
1628 MO_NatU_Ge -> condIntReg GEU x y
1629 MO_NatU_Lt -> condIntReg LU x y
1630 MO_NatU_Le -> condIntReg LEU x y
1632 MO_Flt_Gt -> condFltReg GTT x y
1633 MO_Flt_Ge -> condFltReg GE x y
1634 MO_Flt_Eq -> condFltReg EQQ x y
1635 MO_Flt_Ne -> condFltReg NE x y
1636 MO_Flt_Lt -> condFltReg LTT x y
1637 MO_Flt_Le -> condFltReg LE x y
1639 MO_Dbl_Gt -> condFltReg GTT x y
1640 MO_Dbl_Ge -> condFltReg GE x y
1641 MO_Dbl_Eq -> condFltReg EQQ x y
1642 MO_Dbl_Ne -> condFltReg NE x y
1643 MO_Dbl_Lt -> condFltReg LTT x y
1644 MO_Dbl_Le -> condFltReg LE x y
1646 MO_Nat_Add -> trivialCode ADD x y
1647 MO_Nat_Sub -> trivialCode SUBF y x
1649 MO_NatS_Mul -> trivialCode MULLW x y
1650 MO_NatU_Mul -> trivialCode MULLW x y
1652 MO_NatS_Quot -> trivialCode2 DIVW x y
1653 MO_NatU_Quot -> trivialCode2 DIVWU x y
1655 MO_Nat_And -> trivialCode AND x y
1656 MO_Nat_Or -> trivialCode OR x y
1657 MO_Nat_Xor -> trivialCode XOR x y
1659 MO_Nat_Shl -> trivialCode SLW x y
1660 MO_Nat_Shr -> trivialCode SRW x y
1661 MO_Nat_Sar -> trivialCode SRAW x y
1663 {- MO_NatS_Mul -> trivialCode (SMUL False) x y
1664 MO_NatU_Mul -> trivialCode (UMUL False) x y
1665 MO_NatS_MulMayOflo -> imulMayOflo x y
1667 -- ToDo: teach about V8+ SPARC div instructions
1668 MO_NatS_Quot -> idiv FSLIT(".div") x y
1669 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1670 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1671 MO_NatU_Rem -> idiv FSLIT(".urem") x y -}
1673 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1674 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1675 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1676 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1678 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1679 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1680 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1681 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1683 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1684 [promote x, promote y])
1685 where promote x = StMachOp MO_Flt_to_Dbl [x]
1686 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1689 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1691 getRegister (StInd pk mem)
1692 = getAmode mem `thenNat` \ amode ->
1694 code = amodeCode amode
1695 src = amodeAddr amode
1696 size = primRepToSize pk
1697 code__2 dst = code `snocOL` LD size dst src
1699 returnNat (Any pk code__2)
1701 getRegister (StInt i)
1704 src = ImmInt (fromInteger i)
1705 code dst = unitOL (LI dst src)
1707 returnNat (Any IntRep code)
1709 getRegister (StFloat d)
1710 = getNatLabelNCG `thenNat` \ lbl ->
1711 getNewRegNCG PtrRep `thenNat` \ tmp ->
1712 let code dst = toOL [
1713 SEGMENT RoDataSegment,
1715 DATA F [ImmFloat d],
1716 SEGMENT TextSegment,
1717 LIS tmp (HA (ImmCLbl lbl)),
1718 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1720 returnNat (Any FloatRep code)
1722 getRegister (StDouble d)
1723 = getNatLabelNCG `thenNat` \ lbl ->
1724 getNewRegNCG PtrRep `thenNat` \ tmp ->
1725 let code dst = toOL [
1726 SEGMENT RoDataSegment,
1728 DATA DF [ImmDouble d],
1729 SEGMENT TextSegment,
1730 LIS tmp (HA (ImmCLbl lbl)),
1731 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1733 returnNat (Any DoubleRep code)
1739 LIS dst (HI imm__2),
1740 OR dst dst (RIImm (LO imm__2))]
1742 returnNat (Any PtrRep code)
1744 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1747 imm__2 = case imm of Just x -> x
1748 #endif {- powerpc_TARGET_ARCH -}
1750 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1752 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1756 %************************************************************************
1758 \subsection{The @Amode@ type}
1760 %************************************************************************
1762 @Amode@s: Memory addressing modes passed up the tree.
1764 data Amode = Amode MachRegsAddr InstrBlock
1766 amodeAddr (Amode addr _) = addr
1767 amodeCode (Amode _ code) = code
1770 Now, given a tree (the argument to an StInd) that references memory,
1771 produce a suitable addressing mode.
1773 A Rule of the Game (tm) for Amodes: use of the addr bit must
1774 immediately follow use of the code part, since the code part puts
1775 values in registers which the addr then refers to. So you can't put
1776 anything in between, lest it overwrite some of those registers. If
1777 you need to do some other computation between the code part and use of
1778 the addr bit, first store the effective address from the amode in a
1779 temporary, then do the other computation, and then use the temporary:
1783 ... other computation ...
1787 getAmode :: StixExpr -> NatM Amode
1789 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1791 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1793 #if alpha_TARGET_ARCH
1795 getAmode (StPrim IntSubOp [x, StInt i])
1796 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1797 getRegister x `thenNat` \ register ->
1799 code = registerCode register tmp
1800 reg = registerName register tmp
1801 off = ImmInt (-(fromInteger i))
1803 returnNat (Amode (AddrRegImm reg off) code)
1805 getAmode (StPrim IntAddOp [x, StInt i])
1806 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1807 getRegister x `thenNat` \ register ->
1809 code = registerCode register tmp
1810 reg = registerName register tmp
1811 off = ImmInt (fromInteger i)
1813 returnNat (Amode (AddrRegImm reg off) code)
1817 = returnNat (Amode (AddrImm imm__2) id)
1820 imm__2 = case imm of Just x -> x
1823 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1824 getRegister other `thenNat` \ register ->
1826 code = registerCode register tmp
1827 reg = registerName register tmp
1829 returnNat (Amode (AddrReg reg) code)
1831 #endif {- alpha_TARGET_ARCH -}
1833 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1835 #if i386_TARGET_ARCH
1837 -- This is all just ridiculous, since it carefully undoes
1838 -- what mangleIndexTree has just done.
1839 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1840 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1841 getRegister x `thenNat` \ register ->
1843 code = registerCode register tmp
1844 reg = registerName register tmp
1845 off = ImmInt (-(fromInteger i))
1847 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1849 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1851 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1854 imm__2 = case imm of Just x -> x
1856 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1857 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1858 getRegister x `thenNat` \ register ->
1860 code = registerCode register tmp
1861 reg = registerName register tmp
1862 off = ImmInt (fromInteger i)
1864 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1866 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1867 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1868 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1869 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1870 getRegister x `thenNat` \ register1 ->
1871 getRegister y `thenNat` \ register2 ->
1873 code1 = registerCode register1 tmp1
1874 reg1 = registerName register1 tmp1
1875 code2 = registerCode register2 tmp2
1876 reg2 = registerName register2 tmp2
1877 code__2 = code1 `appOL` code2
1878 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1880 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1885 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1888 imm__2 = case imm of Just x -> x
1891 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1892 getRegister other `thenNat` \ register ->
1894 code = registerCode register tmp
1895 reg = registerName register tmp
1897 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1899 #endif {- i386_TARGET_ARCH -}
1901 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1903 #if sparc_TARGET_ARCH
1905 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1907 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1908 getRegister x `thenNat` \ register ->
1910 code = registerCode register tmp
1911 reg = registerName register tmp
1912 off = ImmInt (-(fromInteger i))
1914 returnNat (Amode (AddrRegImm reg off) code)
1917 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1919 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1920 getRegister x `thenNat` \ register ->
1922 code = registerCode register tmp
1923 reg = registerName register tmp
1924 off = ImmInt (fromInteger i)
1926 returnNat (Amode (AddrRegImm reg off) code)
1928 getAmode (StMachOp MO_Nat_Add [x, y])
1929 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1930 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1931 getRegister x `thenNat` \ register1 ->
1932 getRegister y `thenNat` \ register2 ->
1934 code1 = registerCode register1 tmp1
1935 reg1 = registerName register1 tmp1
1936 code2 = registerCode register2 tmp2
1937 reg2 = registerName register2 tmp2
1938 code__2 = code1 `appOL` code2
1940 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1944 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1946 code = unitOL (SETHI (HI imm__2) tmp)
1948 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1951 imm__2 = case imm of Just x -> x
1954 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1955 getRegister other `thenNat` \ register ->
1957 code = registerCode register tmp
1958 reg = registerName register tmp
1961 returnNat (Amode (AddrRegImm reg off) code)
1963 #endif {- sparc_TARGET_ARCH -}
1965 #ifdef powerpc_TARGET_ARCH
1966 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1968 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1969 getRegister x `thenNat` \ register ->
1971 code = registerCode register tmp
1972 reg = registerName register tmp
1973 off = ImmInt (-(fromInteger i))
1975 returnNat (Amode (AddrRegImm reg off) code)
1978 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1980 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1981 getRegister x `thenNat` \ register ->
1983 code = registerCode register tmp
1984 reg = registerName register tmp
1985 off = ImmInt (fromInteger i)
1987 returnNat (Amode (AddrRegImm reg off) code)
1991 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1993 code = unitOL (LIS tmp (HA imm__2))
1995 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1998 imm__2 = case imm of Just x -> x
2001 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2002 getRegister other `thenNat` \ register ->
2004 code = registerCode register tmp
2005 reg = registerName register tmp
2008 returnNat (Amode (AddrRegImm reg off) code)
2009 #endif {- powerpc_TARGET_ARCH -}
2011 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2014 %************************************************************************
2016 \subsection{The @CondCode@ type}
2018 %************************************************************************
2020 Condition codes passed up the tree.
2022 data CondCode = CondCode Bool Cond InstrBlock
2024 condName (CondCode _ cond _) = cond
2025 condFloat (CondCode is_float _ _) = is_float
2026 condCode (CondCode _ _ code) = code
2029 Set up a condition code for a conditional branch.
2032 getCondCode :: StixExpr -> NatM CondCode
2034 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2036 #if alpha_TARGET_ARCH
2037 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2038 #endif {- alpha_TARGET_ARCH -}
2040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2042 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2043 -- yes, they really do seem to want exactly the same!
2045 getCondCode (StMachOp mop [x, y])
2047 MO_32U_Gt -> condIntCode GTT x y
2048 MO_32U_Ge -> condIntCode GE x y
2049 MO_32U_Eq -> condIntCode EQQ x y
2050 MO_32U_Ne -> condIntCode NE x y
2051 MO_32U_Lt -> condIntCode LTT x y
2052 MO_32U_Le -> condIntCode LE x y
2054 MO_Nat_Eq -> condIntCode EQQ x y
2055 MO_Nat_Ne -> condIntCode NE x y
2057 MO_NatS_Gt -> condIntCode GTT x y
2058 MO_NatS_Ge -> condIntCode GE x y
2059 MO_NatS_Lt -> condIntCode LTT x y
2060 MO_NatS_Le -> condIntCode LE x y
2062 MO_NatU_Gt -> condIntCode GU x y
2063 MO_NatU_Ge -> condIntCode GEU x y
2064 MO_NatU_Lt -> condIntCode LU x y
2065 MO_NatU_Le -> condIntCode LEU x y
2067 MO_Flt_Gt -> condFltCode GTT x y
2068 MO_Flt_Ge -> condFltCode GE x y
2069 MO_Flt_Eq -> condFltCode EQQ x y
2070 MO_Flt_Ne -> condFltCode NE x y
2071 MO_Flt_Lt -> condFltCode LTT x y
2072 MO_Flt_Le -> condFltCode LE x y
2074 MO_Dbl_Gt -> condFltCode GTT x y
2075 MO_Dbl_Ge -> condFltCode GE x y
2076 MO_Dbl_Eq -> condFltCode EQQ x y
2077 MO_Dbl_Ne -> condFltCode NE x y
2078 MO_Dbl_Lt -> condFltCode LTT x y
2079 MO_Dbl_Le -> condFltCode LE x y
2081 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2083 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2085 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH -}
2088 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2093 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2094 passed back up the tree.
2097 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2099 #if alpha_TARGET_ARCH
2100 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2101 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2102 #endif {- alpha_TARGET_ARCH -}
2104 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2105 #if i386_TARGET_ARCH
2107 -- memory vs immediate
2108 condIntCode cond (StInd pk x) y
2109 | Just i <- maybeImm y
2110 = getAmode x `thenNat` \ amode ->
2112 code1 = amodeCode amode
2113 x__2 = amodeAddr amode
2114 sz = primRepToSize pk
2115 code__2 = code1 `snocOL`
2116 CMP sz (OpImm i) (OpAddr x__2)
2118 returnNat (CondCode False cond code__2)
2121 condIntCode cond x (StInt 0)
2122 = getRegister x `thenNat` \ register1 ->
2123 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2125 code1 = registerCode register1 tmp1
2126 src1 = registerName register1 tmp1
2127 code__2 = code1 `snocOL`
2128 TEST L (OpReg src1) (OpReg src1)
2130 returnNat (CondCode False cond code__2)
2132 -- anything vs immediate
2133 condIntCode cond x y
2134 | Just i <- maybeImm y
2135 = getRegister x `thenNat` \ register1 ->
2136 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2138 code1 = registerCode register1 tmp1
2139 src1 = registerName register1 tmp1
2140 code__2 = code1 `snocOL`
2141 CMP L (OpImm i) (OpReg src1)
2143 returnNat (CondCode False cond code__2)
2145 -- memory vs anything
2146 condIntCode cond (StInd pk x) y
2147 = getAmode x `thenNat` \ amode_x ->
2148 getRegister y `thenNat` \ reg_y ->
2149 getNewRegNCG IntRep `thenNat` \ tmp ->
2151 c_x = amodeCode amode_x
2152 am_x = amodeAddr amode_x
2153 c_y = registerCode reg_y tmp
2154 r_y = registerName reg_y tmp
2155 sz = primRepToSize pk
2157 -- optimisation: if there's no code for x, just an amode,
2158 -- use whatever reg y winds up in. Assumes that c_y doesn't
2159 -- clobber any regs in the amode am_x, which I'm not sure is
2160 -- justified. The otherwise clause makes the same assumption.
2161 code__2 | isNilOL c_x
2163 CMP sz (OpReg r_y) (OpAddr am_x)
2167 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2169 CMP sz (OpReg tmp) (OpAddr am_x)
2171 returnNat (CondCode False cond code__2)
2173 -- anything vs memory
2175 condIntCode cond y (StInd pk x)
2176 = getAmode x `thenNat` \ amode_x ->
2177 getRegister y `thenNat` \ reg_y ->
2178 getNewRegNCG IntRep `thenNat` \ tmp ->
2180 c_x = amodeCode amode_x
2181 am_x = amodeAddr amode_x
2182 c_y = registerCode reg_y tmp
2183 r_y = registerName reg_y tmp
2184 sz = primRepToSize pk
2185 -- same optimisation and nagging doubts as previous clause
2186 code__2 | isNilOL c_x
2188 CMP sz (OpAddr am_x) (OpReg r_y)
2192 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2194 CMP sz (OpAddr am_x) (OpReg tmp)
2196 returnNat (CondCode False cond code__2)
2198 -- anything vs anything
2199 condIntCode cond x y
2200 = getRegister x `thenNat` \ register1 ->
2201 getRegister y `thenNat` \ register2 ->
2202 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2203 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2205 code1 = registerCode register1 tmp1
2206 src1 = registerName register1 tmp1
2207 code2 = registerCode register2 tmp2
2208 src2 = registerName register2 tmp2
2209 code__2 = code1 `snocOL`
2210 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2212 CMP L (OpReg src2) (OpReg tmp1)
2214 returnNat (CondCode False cond code__2)
2217 condFltCode cond x y
2218 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2219 getRegister x `thenNat` \ register1 ->
2220 getRegister y `thenNat` \ register2 ->
2221 getNewRegNCG (registerRep register1)
2223 getNewRegNCG (registerRep register2)
2225 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2227 code1 = registerCode register1 tmp1
2228 src1 = registerName register1 tmp1
2230 code2 = registerCode register2 tmp2
2231 src2 = registerName register2 tmp2
2233 code__2 | isAny register1
2234 = code1 `appOL` -- result in tmp1
2240 GMOV src1 tmp1 `appOL`
2244 -- The GCMP insn does the test and sets the zero flag if comparable
2245 -- and true. Hence we always supply EQQ as the condition to test.
2246 returnNat (CondCode True EQQ code__2)
2248 #endif {- i386_TARGET_ARCH -}
2250 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2252 #if sparc_TARGET_ARCH
2254 condIntCode cond x (StInt y)
2256 = getRegister x `thenNat` \ register ->
2257 getNewRegNCG IntRep `thenNat` \ tmp ->
2259 code = registerCode register tmp
2260 src1 = registerName register tmp
2261 src2 = ImmInt (fromInteger y)
2262 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2264 returnNat (CondCode False cond code__2)
2266 condIntCode cond x y
2267 = getRegister x `thenNat` \ register1 ->
2268 getRegister y `thenNat` \ register2 ->
2269 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2270 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2272 code1 = registerCode register1 tmp1
2273 src1 = registerName register1 tmp1
2274 code2 = registerCode register2 tmp2
2275 src2 = registerName register2 tmp2
2276 code__2 = code1 `appOL` code2 `snocOL`
2277 SUB False True src1 (RIReg src2) g0
2279 returnNat (CondCode False cond code__2)
2282 condFltCode cond x y
2283 = getRegister x `thenNat` \ register1 ->
2284 getRegister y `thenNat` \ register2 ->
2285 getNewRegNCG (registerRep register1)
2287 getNewRegNCG (registerRep register2)
2289 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2291 promote x = FxTOy F DF x tmp
2293 pk1 = registerRep register1
2294 code1 = registerCode register1 tmp1
2295 src1 = registerName register1 tmp1
2297 pk2 = registerRep register2
2298 code2 = registerCode register2 tmp2
2299 src2 = registerName register2 tmp2
2303 code1 `appOL` code2 `snocOL`
2304 FCMP True (primRepToSize pk1) src1 src2
2305 else if pk1 == FloatRep then
2306 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2307 FCMP True DF tmp src2
2309 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2310 FCMP True DF src1 tmp
2312 returnNat (CondCode True cond code__2)
2314 #endif {- sparc_TARGET_ARCH -}
2316 #if powerpc_TARGET_ARCH
2318 condIntCode cond x (StInt y)
2320 = getRegister x `thenNat` \ register ->
2321 getNewRegNCG IntRep `thenNat` \ tmp ->
2323 code = registerCode register tmp
2324 src1 = registerName register tmp
2325 src2 = ImmInt (fromInteger y)
2326 code__2 = code `snocOL`
2327 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2329 returnNat (CondCode False cond code__2)
2331 condIntCode cond x y
2332 = getRegister x `thenNat` \ register1 ->
2333 getRegister y `thenNat` \ register2 ->
2334 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2335 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2337 code1 = registerCode register1 tmp1
2338 src1 = registerName register1 tmp1
2339 code2 = registerCode register2 tmp2
2340 src2 = registerName register2 tmp2
2341 code__2 = code1 `appOL` code2 `snocOL`
2342 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2344 returnNat (CondCode False cond code__2)
2346 condFltCode cond x y
2347 = getRegister x `thenNat` \ register1 ->
2348 getRegister y `thenNat` \ register2 ->
2349 getNewRegNCG (registerRep register1)
2351 getNewRegNCG (registerRep register2)
2354 code1 = registerCode register1 tmp1
2355 src1 = registerName register1 tmp1
2356 code2 = registerCode register2 tmp2
2357 src2 = registerName register2 tmp2
2358 code__2 = code1 `appOL` code2 `snocOL`
2361 returnNat (CondCode False cond code__2)
2363 #endif {- powerpc_TARGET_ARCH -}
2366 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2369 %************************************************************************
2371 \subsection{Generating assignments}
2373 %************************************************************************
2375 Assignments are really at the heart of the whole code generation
2376 business. Almost all top-level nodes of any real importance are
2377 assignments, which correspond to loads, stores, or register transfers.
2378 If we're really lucky, some of the register transfers will go away,
2379 because we can use the destination register to complete the code
2380 generation for the right hand side. This only fails when the right
2381 hand side is forced into a fixed register (e.g. the result of a call).
2384 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2385 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2387 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2388 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2390 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2392 #if alpha_TARGET_ARCH
2394 assignIntCode pk (StInd _ dst) src
2395 = getNewRegNCG IntRep `thenNat` \ tmp ->
2396 getAmode dst `thenNat` \ amode ->
2397 getRegister src `thenNat` \ register ->
2399 code1 = amodeCode amode []
2400 dst__2 = amodeAddr amode
2401 code2 = registerCode register tmp []
2402 src__2 = registerName register tmp
2403 sz = primRepToSize pk
2404 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2408 assignIntCode pk dst src
2409 = getRegister dst `thenNat` \ register1 ->
2410 getRegister src `thenNat` \ register2 ->
2412 dst__2 = registerName register1 zeroh
2413 code = registerCode register2 dst__2
2414 src__2 = registerName register2 dst__2
2415 code__2 = if isFixed register2
2416 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2421 #endif {- alpha_TARGET_ARCH -}
2423 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2425 #if i386_TARGET_ARCH
2427 -- non-FP assignment to memory
2428 assignMem_IntCode pk addr src
2429 = getAmode addr `thenNat` \ amode ->
2430 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2431 getNewRegNCG PtrRep `thenNat` \ tmp ->
2433 -- In general, if the address computation for dst may require
2434 -- some insns preceding the addressing mode itself. So there's
2435 -- no guarantee that the code for dst and the code for src won't
2436 -- write the same register. This means either the address or
2437 -- the value needs to be copied into a temporary. We detect the
2438 -- common case where the amode has no code, and elide the copy.
2439 codea = amodeCode amode
2440 dst__a = amodeAddr amode
2442 code | isNilOL codea
2444 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2447 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2449 MOV (primRepToSize pk) opsrc
2450 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2456 -> NatM (InstrBlock,Operand) -- code, operator
2459 | Just x <- maybeImm op
2460 = returnNat (nilOL, OpImm x)
2463 = getRegister op `thenNat` \ register ->
2464 getNewRegNCG (registerRep register)
2466 let code = registerCode register tmp
2467 reg = registerName register tmp
2469 returnNat (code, OpReg reg)
2471 -- Assign; dst is a reg, rhs is mem
2472 assignReg_IntCode pk reg (StInd pks src)
2473 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2474 getAmode src `thenNat` \ amode ->
2475 getRegisterReg reg `thenNat` \ reg_dst ->
2477 c_addr = amodeCode amode
2478 am_addr = amodeAddr amode
2479 r_dst = registerName reg_dst tmp
2480 szs = primRepToSize pks
2489 code = c_addr `snocOL`
2490 opc (OpAddr am_addr) (OpReg r_dst)
2494 -- dst is a reg, but src could be anything
2495 assignReg_IntCode pk reg src
2496 = getRegisterReg reg `thenNat` \ registerd ->
2497 getRegister src `thenNat` \ registers ->
2498 getNewRegNCG IntRep `thenNat` \ tmp ->
2500 r_dst = registerName registerd tmp
2501 r_src = registerName registers r_dst
2502 c_src = registerCode registers r_dst
2504 code = c_src `snocOL`
2505 MOV L (OpReg r_src) (OpReg r_dst)
2509 #endif {- i386_TARGET_ARCH -}
2511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2513 #if sparc_TARGET_ARCH
2515 assignMem_IntCode pk addr src
2516 = getNewRegNCG IntRep `thenNat` \ tmp ->
2517 getAmode addr `thenNat` \ amode ->
2518 getRegister src `thenNat` \ register ->
2520 code1 = amodeCode amode
2521 dst__2 = amodeAddr amode
2522 code2 = registerCode register tmp
2523 src__2 = registerName register tmp
2524 sz = primRepToSize pk
2525 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2529 assignReg_IntCode pk reg src
2530 = getRegister src `thenNat` \ register2 ->
2531 getRegisterReg reg `thenNat` \ register1 ->
2532 getNewRegNCG IntRep `thenNat` \ tmp ->
2534 dst__2 = registerName register1 tmp
2535 code = registerCode register2 dst__2
2536 src__2 = registerName register2 dst__2
2537 code__2 = if isFixed register2
2538 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2543 #endif {- sparc_TARGET_ARCH -}
2545 #if powerpc_TARGET_ARCH
2547 assignMem_IntCode pk addr src
2548 = getNewRegNCG IntRep `thenNat` \ tmp ->
2549 getAmode addr `thenNat` \ amode ->
2550 getRegister src `thenNat` \ register ->
2552 code1 = amodeCode amode
2553 dst__2 = amodeAddr amode
2554 code2 = registerCode register tmp
2555 src__2 = registerName register tmp
2556 sz = primRepToSize pk
2557 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2561 assignReg_IntCode pk reg src
2562 = getRegister src `thenNat` \ register2 ->
2563 getRegisterReg reg `thenNat` \ register1 ->
2565 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2566 code = registerCode register2 dst__2
2567 src__2 = registerName register2 dst__2
2568 code__2 = if isFixed register2
2569 then code `snocOL` MR dst__2 src__2
2574 #endif {- powerpc_TARGET_ARCH -}
2576 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2579 % --------------------------------
2580 Floating-point assignments:
2581 % --------------------------------
2584 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2585 #if alpha_TARGET_ARCH
2587 assignFltCode pk (StInd _ dst) src
2588 = getNewRegNCG pk `thenNat` \ tmp ->
2589 getAmode dst `thenNat` \ amode ->
2590 getRegister src `thenNat` \ register ->
2592 code1 = amodeCode amode []
2593 dst__2 = amodeAddr amode
2594 code2 = registerCode register tmp []
2595 src__2 = registerName register tmp
2596 sz = primRepToSize pk
2597 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2601 assignFltCode pk dst src
2602 = getRegister dst `thenNat` \ register1 ->
2603 getRegister src `thenNat` \ register2 ->
2605 dst__2 = registerName register1 zeroh
2606 code = registerCode register2 dst__2
2607 src__2 = registerName register2 dst__2
2608 code__2 = if isFixed register2
2609 then code . mkSeqInstr (FMOV src__2 dst__2)
2614 #endif {- alpha_TARGET_ARCH -}
2616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2618 #if i386_TARGET_ARCH
2620 -- Floating point assignment to memory
2621 assignMem_FltCode pk addr src
2622 = getRegister src `thenNat` \ reg_src ->
2623 getRegister addr `thenNat` \ reg_addr ->
2624 getNewRegNCG pk `thenNat` \ tmp_src ->
2625 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2626 let r_src = registerName reg_src tmp_src
2627 c_src = registerCode reg_src tmp_src
2628 r_addr = registerName reg_addr tmp_addr
2629 c_addr = registerCode reg_addr tmp_addr
2630 sz = primRepToSize pk
2632 code = c_src `appOL`
2633 -- no need to preserve r_src across the addr computation,
2634 -- since r_src must be a float reg
2635 -- whilst r_addr is an int reg
2638 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2642 -- Floating point assignment to a register/temporary
2643 assignReg_FltCode pk reg src
2644 = getRegisterReg reg `thenNat` \ reg_dst ->
2645 getRegister src `thenNat` \ reg_src ->
2646 getNewRegNCG pk `thenNat` \ tmp ->
2648 r_dst = registerName reg_dst tmp
2649 r_src = registerName reg_src r_dst
2650 c_src = registerCode reg_src r_dst
2652 code = if isFixed reg_src
2653 then c_src `snocOL` GMOV r_src r_dst
2659 #endif {- i386_TARGET_ARCH -}
2661 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2663 #if sparc_TARGET_ARCH
2665 -- Floating point assignment to memory
2666 assignMem_FltCode pk addr src
2667 = getNewRegNCG pk `thenNat` \ tmp1 ->
2668 getAmode addr `thenNat` \ amode ->
2669 getRegister src `thenNat` \ register ->
2671 sz = primRepToSize pk
2672 dst__2 = amodeAddr amode
2674 code1 = amodeCode amode
2675 code2 = registerCode register tmp1
2677 src__2 = registerName register tmp1
2678 pk__2 = registerRep register
2679 sz__2 = primRepToSize pk__2
2681 code__2 = code1 `appOL` code2 `appOL`
2683 then unitOL (ST sz src__2 dst__2)
2684 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2688 -- Floating point assignment to a register/temporary
2689 -- Why is this so bizarrely ugly?
2690 assignReg_FltCode pk reg src
2691 = getRegisterReg reg `thenNat` \ register1 ->
2692 getRegister src `thenNat` \ register2 ->
2694 pk__2 = registerRep register2
2695 sz__2 = primRepToSize pk__2
2697 getNewRegNCG pk__2 `thenNat` \ tmp ->
2699 sz = primRepToSize pk
2700 dst__2 = registerName register1 g0 -- must be Fixed
2701 reg__2 = if pk /= pk__2 then tmp else dst__2
2702 code = registerCode register2 reg__2
2703 src__2 = registerName register2 reg__2
2706 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2707 else if isFixed register2 then
2708 code `snocOL` FMOV sz src__2 dst__2
2714 #endif {- sparc_TARGET_ARCH -}
2716 #if powerpc_TARGET_ARCH
2718 -- Floating point assignment to memory
2719 assignMem_FltCode pk addr src
2720 = getNewRegNCG pk `thenNat` \ tmp1 ->
2721 getAmode addr `thenNat` \ amode ->
2722 getRegister src `thenNat` \ register ->
2724 sz = primRepToSize pk
2725 dst__2 = amodeAddr amode
2727 code1 = amodeCode amode
2728 code2 = registerCode register tmp1
2730 src__2 = registerName register tmp1
2731 pk__2 = registerRep register
2732 sz__2 = primRepToSize pk__2
2734 code__2 = if pk__2 == DoubleRep || pk == pk__2
2735 then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2736 else panic "###PPC MachCode.assignMem_FltCode: FloatRep"
2737 {- code__2 = code1 `appOL` code2 `appOL`
2739 then unitOL (ST sz src__2 dst__2)
2740 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] -}
2744 -- Floating point assignment to a register/temporary
2745 assignReg_FltCode pk reg src
2746 = getRegisterReg reg `thenNat` \ reg_dst ->
2747 getRegister src `thenNat` \ reg_src ->
2748 getNewRegNCG pk `thenNat` \ tmp ->
2750 r_dst = registerName reg_dst tmp
2751 r_src = registerName reg_src r_dst
2752 c_src = registerCode reg_src r_dst
2754 code = if isFixed reg_src
2755 then c_src `snocOL` MR r_dst r_src
2759 #endif {- powerpc_TARGET_ARCH -}
2761 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2764 %************************************************************************
2766 \subsection{Generating an unconditional branch}
2768 %************************************************************************
2770 We accept two types of targets: an immediate CLabel or a tree that
2771 gets evaluated into a register. Any CLabels which are AsmTemporaries
2772 are assumed to be in the local block of code, close enough for a
2773 branch instruction. Other CLabels are assumed to be far away.
2775 (If applicable) Do not fill the delay slots here; you will confuse the
2779 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2783 #if alpha_TARGET_ARCH
2785 genJump (StCLbl lbl)
2786 | isAsmTemp lbl = returnInstr (BR target)
2787 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2789 target = ImmCLbl lbl
2792 = getRegister tree `thenNat` \ register ->
2793 getNewRegNCG PtrRep `thenNat` \ tmp ->
2795 dst = registerName register pv
2796 code = registerCode register pv
2797 target = registerName register pv
2799 if isFixed register then
2800 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2802 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2804 #endif {- alpha_TARGET_ARCH -}
2806 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2808 #if i386_TARGET_ARCH
2810 genJump dsts (StInd pk mem)
2811 = getAmode mem `thenNat` \ amode ->
2813 code = amodeCode amode
2814 target = amodeAddr amode
2816 returnNat (code `snocOL` JMP dsts (OpAddr target))
2820 = returnNat (unitOL (JMP dsts (OpImm target)))
2823 = getRegister tree `thenNat` \ register ->
2824 getNewRegNCG PtrRep `thenNat` \ tmp ->
2826 code = registerCode register tmp
2827 target = registerName register tmp
2829 returnNat (code `snocOL` JMP dsts (OpReg target))
2832 target = case imm of Just x -> x
2834 #endif {- i386_TARGET_ARCH -}
2836 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2838 #if sparc_TARGET_ARCH
2840 genJump dsts (StCLbl lbl)
2841 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2842 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2843 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2845 target = ImmCLbl lbl
2848 = getRegister tree `thenNat` \ register ->
2849 getNewRegNCG PtrRep `thenNat` \ tmp ->
2851 code = registerCode register tmp
2852 target = registerName register tmp
2854 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2856 #endif {- sparc_TARGET_ARCH -}
2858 #if powerpc_TARGET_ARCH
2859 genJump dsts (StCLbl lbl)
2860 = returnNat (toOL [BCC ALWAYS lbl])
2863 = getRegister tree `thenNat` \ register ->
2864 getNewRegNCG PtrRep `thenNat` \ tmp ->
2866 code = registerCode register tmp
2867 target = registerName register tmp
2869 returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
2870 #endif {- sparc_TARGET_ARCH -}
2872 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2877 %************************************************************************
2879 \subsection{Conditional jumps}
2881 %************************************************************************
2883 Conditional jumps are always to local labels, so we can use branch
2884 instructions. We peek at the arguments to decide what kind of
2887 ALPHA: For comparisons with 0, we're laughing, because we can just do
2888 the desired conditional branch.
2890 I386: First, we have to ensure that the condition
2891 codes are set according to the supplied comparison operation.
2893 SPARC: First, we have to ensure that the condition codes are set
2894 according to the supplied comparison operation. We generate slightly
2895 different code for floating point comparisons, because a floating
2896 point operation cannot directly precede a @BF@. We assume the worst
2897 and fill that slot with a @NOP@.
2899 SPARC: Do not fill the delay slots here; you will confuse the register
2904 :: CLabel -- the branch target
2905 -> StixExpr -- the condition on which to branch
2908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2910 #if alpha_TARGET_ARCH
2912 genCondJump lbl (StPrim op [x, StInt 0])
2913 = getRegister x `thenNat` \ register ->
2914 getNewRegNCG (registerRep register)
2917 code = registerCode register tmp
2918 value = registerName register tmp
2919 pk = registerRep register
2920 target = ImmCLbl lbl
2922 returnSeq code [BI (cmpOp op) value target]
2924 cmpOp CharGtOp = GTT
2926 cmpOp CharEqOp = EQQ
2928 cmpOp CharLtOp = LTT
2937 cmpOp WordGeOp = ALWAYS
2938 cmpOp WordEqOp = EQQ
2940 cmpOp WordLtOp = NEVER
2941 cmpOp WordLeOp = EQQ
2943 cmpOp AddrGeOp = ALWAYS
2944 cmpOp AddrEqOp = EQQ
2946 cmpOp AddrLtOp = NEVER
2947 cmpOp AddrLeOp = EQQ
2949 genCondJump lbl (StPrim op [x, StDouble 0.0])
2950 = getRegister x `thenNat` \ register ->
2951 getNewRegNCG (registerRep register)
2954 code = registerCode register tmp
2955 value = registerName register tmp
2956 pk = registerRep register
2957 target = ImmCLbl lbl
2959 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2961 cmpOp FloatGtOp = GTT
2962 cmpOp FloatGeOp = GE
2963 cmpOp FloatEqOp = EQQ
2964 cmpOp FloatNeOp = NE
2965 cmpOp FloatLtOp = LTT
2966 cmpOp FloatLeOp = LE
2967 cmpOp DoubleGtOp = GTT
2968 cmpOp DoubleGeOp = GE
2969 cmpOp DoubleEqOp = EQQ
2970 cmpOp DoubleNeOp = NE
2971 cmpOp DoubleLtOp = LTT
2972 cmpOp DoubleLeOp = LE
2974 genCondJump lbl (StPrim op [x, y])
2976 = trivialFCode pr instr x y `thenNat` \ register ->
2977 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2979 code = registerCode register tmp
2980 result = registerName register tmp
2981 target = ImmCLbl lbl
2983 returnNat (code . mkSeqInstr (BF cond result target))
2985 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2987 fltCmpOp op = case op of
3001 (instr, cond) = case op of
3002 FloatGtOp -> (FCMP TF LE, EQQ)
3003 FloatGeOp -> (FCMP TF LTT, EQQ)
3004 FloatEqOp -> (FCMP TF EQQ, NE)
3005 FloatNeOp -> (FCMP TF EQQ, EQQ)
3006 FloatLtOp -> (FCMP TF LTT, NE)
3007 FloatLeOp -> (FCMP TF LE, NE)
3008 DoubleGtOp -> (FCMP TF LE, EQQ)
3009 DoubleGeOp -> (FCMP TF LTT, EQQ)
3010 DoubleEqOp -> (FCMP TF EQQ, NE)
3011 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3012 DoubleLtOp -> (FCMP TF LTT, NE)
3013 DoubleLeOp -> (FCMP TF LE, NE)
3015 genCondJump lbl (StPrim op [x, y])
3016 = trivialCode instr x y `thenNat` \ register ->
3017 getNewRegNCG IntRep `thenNat` \ tmp ->
3019 code = registerCode register tmp
3020 result = registerName register tmp
3021 target = ImmCLbl lbl
3023 returnNat (code . mkSeqInstr (BI cond result target))
3025 (instr, cond) = case op of
3026 CharGtOp -> (CMP LE, EQQ)
3027 CharGeOp -> (CMP LTT, EQQ)
3028 CharEqOp -> (CMP EQQ, NE)
3029 CharNeOp -> (CMP EQQ, EQQ)
3030 CharLtOp -> (CMP LTT, NE)
3031 CharLeOp -> (CMP LE, NE)
3032 IntGtOp -> (CMP LE, EQQ)
3033 IntGeOp -> (CMP LTT, EQQ)
3034 IntEqOp -> (CMP EQQ, NE)
3035 IntNeOp -> (CMP EQQ, EQQ)
3036 IntLtOp -> (CMP LTT, NE)
3037 IntLeOp -> (CMP LE, NE)
3038 WordGtOp -> (CMP ULE, EQQ)
3039 WordGeOp -> (CMP ULT, EQQ)
3040 WordEqOp -> (CMP EQQ, NE)
3041 WordNeOp -> (CMP EQQ, EQQ)
3042 WordLtOp -> (CMP ULT, NE)
3043 WordLeOp -> (CMP ULE, NE)
3044 AddrGtOp -> (CMP ULE, EQQ)
3045 AddrGeOp -> (CMP ULT, EQQ)
3046 AddrEqOp -> (CMP EQQ, NE)
3047 AddrNeOp -> (CMP EQQ, EQQ)
3048 AddrLtOp -> (CMP ULT, NE)
3049 AddrLeOp -> (CMP ULE, NE)
3051 #endif {- alpha_TARGET_ARCH -}
3053 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3055 #if i386_TARGET_ARCH
3057 genCondJump lbl bool
3058 = getCondCode bool `thenNat` \ condition ->
3060 code = condCode condition
3061 cond = condName condition
3063 returnNat (code `snocOL` JXX cond lbl)
3065 #endif {- i386_TARGET_ARCH -}
3067 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3069 #if sparc_TARGET_ARCH
3071 genCondJump lbl bool
3072 = getCondCode bool `thenNat` \ condition ->
3074 code = condCode condition
3075 cond = condName condition
3076 target = ImmCLbl lbl
3081 if condFloat condition
3082 then [NOP, BF cond False target, NOP]
3083 else [BI cond False target, NOP]
3087 #endif {- sparc_TARGET_ARCH -}
3089 #if powerpc_TARGET_ARCH
3091 genCondJump lbl bool
3092 = getCondCode bool `thenNat` \ condition ->
3094 code = condCode condition
3095 cond = condName condition
3096 target = ImmCLbl lbl
3099 code `snocOL` BCC cond lbl )
3101 #endif {- powerpc_TARGET_ARCH -}
3103 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3105 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3108 %************************************************************************
3110 \subsection{Generating C calls}
3112 %************************************************************************
3114 Now the biggest nightmare---calls. Most of the nastiness is buried in
3115 @get_arg@, which moves the arguments to the correct registers/stack
3116 locations. Apart from that, the code is easy.
3118 (If applicable) Do not fill the delay slots here; you will confuse the
3123 :: (Either FastString StixExpr) -- function to call
3125 -> PrimRep -- type of the result
3126 -> [StixExpr] -- arguments (of mixed type)
3129 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3131 #if alpha_TARGET_ARCH
3133 genCCall fn cconv kind args
3134 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3135 `thenNat` \ ((unused,_), argCode) ->
3137 nRegs = length allArgRegs - length unused
3138 code = asmSeqThen (map ($ []) argCode)
3141 LDA pv (AddrImm (ImmLab (ptext fn))),
3142 JSR ra (AddrReg pv) nRegs,
3143 LDGP gp (AddrReg ra)]
3145 ------------------------
3146 {- Try to get a value into a specific register (or registers) for
3147 a call. The first 6 arguments go into the appropriate
3148 argument register (separate registers for integer and floating
3149 point arguments, but used in lock-step), and the remaining
3150 arguments are dumped to the stack, beginning at 0(sp). Our
3151 first argument is a pair of the list of remaining argument
3152 registers to be assigned for this call and the next stack
3153 offset to use for overflowing arguments. This way,
3154 @get_Arg@ can be applied to all of a call's arguments using
3158 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3159 -> StixTree -- Current argument
3160 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3162 -- We have to use up all of our argument registers first...
3164 get_arg ((iDst,fDst):dsts, offset) arg
3165 = getRegister arg `thenNat` \ register ->
3167 reg = if isFloatingRep pk then fDst else iDst
3168 code = registerCode register reg
3169 src = registerName register reg
3170 pk = registerRep register
3173 if isFloatingRep pk then
3174 ((dsts, offset), if isFixed register then
3175 code . mkSeqInstr (FMOV src fDst)
3178 ((dsts, offset), if isFixed register then
3179 code . mkSeqInstr (OR src (RIReg src) iDst)
3182 -- Once we have run out of argument registers, we move to the
3185 get_arg ([], offset) arg
3186 = getRegister arg `thenNat` \ register ->
3187 getNewRegNCG (registerRep register)
3190 code = registerCode register tmp
3191 src = registerName register tmp
3192 pk = registerRep register
3193 sz = primRepToSize pk
3195 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3197 #endif {- alpha_TARGET_ARCH -}
3199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3201 #if i386_TARGET_ARCH
3203 genCCall fn cconv ret_rep args
3205 (reverse args) `thenNat` \ sizes_n_codes ->
3206 getDeltaNat `thenNat` \ delta ->
3207 let (sizes, push_codes) = unzip sizes_n_codes
3208 tot_arg_size = sum sizes
3210 -- deal with static vs dynamic call targets
3213 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3215 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3216 ASSERT(case dyn_rep of { L -> True; _ -> False})
3217 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3219 `thenNat` \ callinsns ->
3220 let push_code = concatOL push_codes
3221 call = callinsns `appOL`
3223 -- Deallocate parameters after call for ccall;
3224 -- but not for stdcall (callee does it)
3225 (if cconv == StdCallConv then [] else
3226 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3228 [DELTA (delta + tot_arg_size)]
3231 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3232 returnNat (push_code `appOL` call)
3235 -- function names that begin with '.' are assumed to be special
3236 -- internally generated names like '.mul,' which don't get an
3237 -- underscore prefix
3238 -- ToDo:needed (WDP 96/03) ???
3239 fn_u = unpackFS (unLeft fn)
3242 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3243 | otherwise -- General case
3244 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3246 stdcallsize tot_arg_size
3247 | cconv == StdCallConv = '@':show tot_arg_size
3255 push_arg :: StixExpr{-current argument-}
3256 -> NatM (Int, InstrBlock) -- argsz, code
3259 | is64BitRep arg_rep
3260 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3261 getDeltaNat `thenNat` \ delta ->
3262 setDeltaNat (delta - 8) `thenNat` \ _ ->
3263 let r_lo = VirtualRegI vr_lo
3264 r_hi = getHiVRegFromLo r_lo
3267 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3268 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3271 = get_op arg `thenNat` \ (code, reg, sz) ->
3272 getDeltaNat `thenNat` \ delta ->
3273 arg_size sz `bind` \ size ->
3274 setDeltaNat (delta-size) `thenNat` \ _ ->
3275 if (case sz of DF -> True; F -> True; _ -> False)
3276 then returnNat (size,
3278 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3280 GST sz reg (AddrBaseIndex (Just esp)
3284 else returnNat (size,
3286 PUSH L (OpReg reg) `snocOL`
3290 arg_rep = repOfStixExpr arg
3295 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3298 = getRegister op `thenNat` \ register ->
3299 getNewRegNCG (registerRep register)
3302 code = registerCode register tmp
3303 reg = registerName register tmp
3304 pk = registerRep register
3305 sz = primRepToSize pk
3307 returnNat (code, reg, sz)
3309 #endif {- i386_TARGET_ARCH -}
3311 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3313 #if sparc_TARGET_ARCH
3315 The SPARC calling convention is an absolute
3316 nightmare. The first 6x32 bits of arguments are mapped into
3317 %o0 through %o5, and the remaining arguments are dumped to the
3318 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3320 If we have to put args on the stack, move %o6==%sp down by
3321 the number of words to go on the stack, to ensure there's enough space.
3323 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3324 16 words above the stack pointer is a word for the address of
3325 a structure return value. I use this as a temporary location
3326 for moving values from float to int regs. Certainly it isn't
3327 safe to put anything in the 16 words starting at %sp, since
3328 this area can get trashed at any time due to window overflows
3329 caused by signal handlers.
3331 A final complication (if the above isn't enough) is that
3332 we can't blithely calculate the arguments one by one into
3333 %o0 .. %o5. Consider the following nested calls:
3337 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3338 the inner call will itself use %o0, which trashes the value put there
3339 in preparation for the outer call. Upshot: we need to calculate the
3340 args into temporary regs, and move those to arg regs or onto the
3341 stack only immediately prior to the call proper. Sigh.
3344 genCCall fn cconv kind args
3345 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3347 (argcodes, vregss) = unzip argcode_and_vregs
3348 n_argRegs = length allArgRegs
3349 n_argRegs_used = min (length vregs) n_argRegs
3350 vregs = concat vregss
3352 -- deal with static vs dynamic call targets
3355 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3357 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3358 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3360 `thenNat` \ callinsns ->
3362 argcode = concatOL argcodes
3363 (move_sp_down, move_sp_up)
3364 = let diff = length vregs - n_argRegs
3365 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3368 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3370 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3372 returnNat (argcode `appOL`
3373 move_sp_down `appOL`
3374 transfer_code `appOL`
3379 -- function names that begin with '.' are assumed to be special
3380 -- internally generated names like '.mul,' which don't get an
3381 -- underscore prefix
3382 -- ToDo:needed (WDP 96/03) ???
3383 fn_static = unLeft fn
3384 fn__2 = case (headFS fn_static) of
3385 '.' -> ImmLit (ftext fn_static)
3386 _ -> ImmLab False (ftext fn_static)
3388 -- move args from the integer vregs into which they have been
3389 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3390 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3392 move_final [] _ offset -- all args done
3395 move_final (v:vs) [] offset -- out of aregs; move to stack
3396 = ST W v (spRel offset)
3397 : move_final vs [] (offset+1)
3399 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3400 = OR False g0 (RIReg v) a
3401 : move_final vs az offset
3403 -- generate code to calculate an argument, and move it into one
3404 -- or two integer vregs.
3405 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3406 arg_to_int_vregs arg
3407 | is64BitRep (repOfStixExpr arg)
3408 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3409 let r_lo = VirtualRegI vr_lo
3410 r_hi = getHiVRegFromLo r_lo
3411 in returnNat (code, [r_hi, r_lo])
3413 = getRegister arg `thenNat` \ register ->
3414 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3415 let code = registerCode register tmp
3416 src = registerName register tmp
3417 pk = registerRep register
3419 -- the value is in src. Get it into 1 or 2 int vregs.
3422 getNewRegNCG WordRep `thenNat` \ v1 ->
3423 getNewRegNCG WordRep `thenNat` \ v2 ->
3426 FMOV DF src f0 `snocOL`
3427 ST F f0 (spRel 16) `snocOL`
3428 LD W (spRel 16) v1 `snocOL`
3429 ST F (fPair f0) (spRel 16) `snocOL`
3435 getNewRegNCG WordRep `thenNat` \ v1 ->
3438 ST F src (spRel 16) `snocOL`
3444 getNewRegNCG WordRep `thenNat` \ v1 ->
3446 code `snocOL` OR False g0 (RIReg src) v1
3450 #endif {- sparc_TARGET_ARCH -}
3452 #if powerpc_TARGET_ARCH
3454 The PowerPC calling convention (at least for Darwin/Mac OS X)
3455 is described in Apple's document
3456 "Inside Mac OS X - Mach-O Runtime Architecture".
3457 Parameters may be passed in general-purpose registers, in
3458 floating point registers, or on the stack. Stack space is
3459 always reserved for parameters, even if they are passed in registers.
3460 The called routine may choose to save parameters from registers
3461 to the corresponding space on the stack.
3462 The parameter area should be part of the caller's stack frame,
3463 allocated in the caller's prologue code (large enough to hold
3464 the parameter lists for all called routines). The NCG already
3465 uses the space that we should use as a parameter area for register
3466 spilling, so we allocate a new stack frame just before ccalling.
3467 That way we don't need to decide beforehand how much space to
3468 reserve for parameters.
3471 genCCall fn cconv kind args
3472 = mapNat prepArg args `thenNat` \ preppedArgs ->
3474 (argReps,argCodes,vregs) = unzip3 preppedArgs
3476 -- size of linkage area + size of arguments, in bytes
3477 stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3478 roundTo16 x | x `mod` 16 == 0 = x
3479 | otherwise = x + 16 - (x `mod` 16)
3481 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3482 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3484 (moveFinalCode,usedRegs) = move_final
3486 allArgRegs allFPArgRegs
3490 passArguments = concatOL argCodes
3491 `appOL` move_sp_down
3492 `appOL` moveFinalCode
3496 addImportNat lbl `thenNat` \ _ ->
3497 returnNat (passArguments
3498 `snocOL` BL (ImmLit $ ftext
3501 `appendFS` FSLIT("$stub")))
3505 getRegister dyn `thenNat` \ dynReg ->
3506 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3507 returnNat (registerCode dynReg tmp
3508 `appOL` passArguments
3509 `snocOL` MTCTR (registerName dynReg tmp)
3510 `snocOL` BCTRL usedRegs
3514 | is64BitRep (repOfStixExpr arg)
3515 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3516 let r_lo = VirtualRegI vr_lo
3517 r_hi = getHiVRegFromLo r_lo
3518 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3520 = getRegister arg `thenNat` \ register ->
3521 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3522 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3523 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3524 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3525 | not (is64BitRep rep) =
3528 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3531 fpr : fprs -> MR fpr vr
3532 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3533 ((take 1 fprs) ++ accumUsed)
3535 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3538 fpr : fprs -> MR fpr vr
3539 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3540 ((take 1 fprs) ++ accumUsed)
3541 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3543 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3546 gpr : gprs -> MR gpr vr
3547 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3548 ((take 1 gprs) ++ accumUsed)
3550 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3553 storeWord vr (gpr:_) offset = MR gpr vr
3554 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3556 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3558 `snocOL` storeWord vr_hi gprs stackOffset
3559 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3560 ((take 2 gprs) ++ accumUsed)
3561 #endif {- powerpc_TARGET_ARCH -}
3563 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3566 %************************************************************************
3568 \subsection{Support bits}
3570 %************************************************************************
3572 %************************************************************************
3574 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3576 %************************************************************************
3578 Turn those condition codes into integers now (when they appear on
3579 the right hand side of an assignment).
3581 (If applicable) Do not fill the delay slots here; you will confuse the
3585 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3587 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3589 #if alpha_TARGET_ARCH
3590 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3591 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3592 #endif {- alpha_TARGET_ARCH -}
3594 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3596 #if i386_TARGET_ARCH
3599 = condIntCode cond x y `thenNat` \ condition ->
3600 getNewRegNCG IntRep `thenNat` \ tmp ->
3602 code = condCode condition
3603 cond = condName condition
3604 code__2 dst = code `appOL` toOL [
3605 SETCC cond (OpReg tmp),
3606 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3607 MOV L (OpReg tmp) (OpReg dst)]
3609 returnNat (Any IntRep code__2)
3612 = getNatLabelNCG `thenNat` \ lbl1 ->
3613 getNatLabelNCG `thenNat` \ lbl2 ->
3614 condFltCode cond x y `thenNat` \ condition ->
3616 code = condCode condition
3617 cond = condName condition
3618 code__2 dst = code `appOL` toOL [
3620 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3623 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3626 returnNat (Any IntRep code__2)
3628 #endif {- i386_TARGET_ARCH -}
3630 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3632 #if sparc_TARGET_ARCH
3634 condIntReg EQQ x (StInt 0)
3635 = getRegister x `thenNat` \ register ->
3636 getNewRegNCG IntRep `thenNat` \ tmp ->
3638 code = registerCode register tmp
3639 src = registerName register tmp
3640 code__2 dst = code `appOL` toOL [
3641 SUB False True g0 (RIReg src) g0,
3642 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3644 returnNat (Any IntRep code__2)
3647 = getRegister x `thenNat` \ register1 ->
3648 getRegister y `thenNat` \ register2 ->
3649 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3650 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3652 code1 = registerCode register1 tmp1
3653 src1 = registerName register1 tmp1
3654 code2 = registerCode register2 tmp2
3655 src2 = registerName register2 tmp2
3656 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3657 XOR False src1 (RIReg src2) dst,
3658 SUB False True g0 (RIReg dst) g0,
3659 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3661 returnNat (Any IntRep code__2)
3663 condIntReg NE x (StInt 0)
3664 = getRegister x `thenNat` \ register ->
3665 getNewRegNCG IntRep `thenNat` \ tmp ->
3667 code = registerCode register tmp
3668 src = registerName register tmp
3669 code__2 dst = code `appOL` toOL [
3670 SUB False True g0 (RIReg src) g0,
3671 ADD True False g0 (RIImm (ImmInt 0)) dst]
3673 returnNat (Any IntRep code__2)
3676 = getRegister x `thenNat` \ register1 ->
3677 getRegister y `thenNat` \ register2 ->
3678 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3679 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3681 code1 = registerCode register1 tmp1
3682 src1 = registerName register1 tmp1
3683 code2 = registerCode register2 tmp2
3684 src2 = registerName register2 tmp2
3685 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3686 XOR False src1 (RIReg src2) dst,
3687 SUB False True g0 (RIReg dst) g0,
3688 ADD True False g0 (RIImm (ImmInt 0)) dst]
3690 returnNat (Any IntRep code__2)
3693 = getNatLabelNCG `thenNat` \ lbl1 ->
3694 getNatLabelNCG `thenNat` \ lbl2 ->
3695 condIntCode cond x y `thenNat` \ condition ->
3697 code = condCode condition
3698 cond = condName condition
3699 code__2 dst = code `appOL` toOL [
3700 BI cond False (ImmCLbl lbl1), NOP,
3701 OR False g0 (RIImm (ImmInt 0)) dst,
3702 BI ALWAYS False (ImmCLbl lbl2), NOP,
3704 OR False g0 (RIImm (ImmInt 1)) dst,
3707 returnNat (Any IntRep code__2)
3710 = getNatLabelNCG `thenNat` \ lbl1 ->
3711 getNatLabelNCG `thenNat` \ lbl2 ->
3712 condFltCode cond x y `thenNat` \ condition ->
3714 code = condCode condition
3715 cond = condName condition
3716 code__2 dst = code `appOL` toOL [
3718 BF cond False (ImmCLbl lbl1), NOP,
3719 OR False g0 (RIImm (ImmInt 0)) dst,
3720 BI ALWAYS False (ImmCLbl lbl2), NOP,
3722 OR False g0 (RIImm (ImmInt 1)) dst,
3725 returnNat (Any IntRep code__2)
3727 #endif {- sparc_TARGET_ARCH -}
3729 #if powerpc_TARGET_ARCH
3731 = getNatLabelNCG `thenNat` \ lbl ->
3732 condIntCode cond x y `thenNat` \ condition ->
3734 code = condCode condition
3735 cond = condName condition
3736 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3741 returnNat (Any IntRep code__2)
3744 = getNatLabelNCG `thenNat` \ lbl ->
3745 condFltCode cond x y `thenNat` \ condition ->
3747 code = condCode condition
3748 cond = condName condition
3749 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3754 returnNat (Any IntRep code__2)
3755 #endif {- powerpc_TARGET_ARCH -}
3757 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3760 %************************************************************************
3762 \subsubsection{@trivial*Code@: deal with trivial instructions}
3764 %************************************************************************
3766 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3767 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3768 for constants on the right hand side, because that's where the generic
3769 optimizer will have put them.
3771 Similarly, for unary instructions, we don't have to worry about
3772 matching an StInt as the argument, because genericOpt will already
3773 have handled the constant-folding.
3777 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3778 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3779 -> Maybe (Operand -> Operand -> Instr)
3780 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3781 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3783 -> StixExpr -> StixExpr -- the two arguments
3788 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3789 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3790 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3791 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3793 -> StixExpr -> StixExpr -- the two arguments
3797 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3798 ,IF_ARCH_i386 ((Operand -> Instr)
3799 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3800 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3802 -> StixExpr -- the one argument
3807 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3808 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3809 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3810 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3812 -> StixExpr -- the one argument
3815 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3817 #if alpha_TARGET_ARCH
3819 trivialCode instr x (StInt y)
3821 = getRegister x `thenNat` \ register ->
3822 getNewRegNCG IntRep `thenNat` \ tmp ->
3824 code = registerCode register tmp
3825 src1 = registerName register tmp
3826 src2 = ImmInt (fromInteger y)
3827 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3829 returnNat (Any IntRep code__2)
3831 trivialCode instr x y
3832 = getRegister x `thenNat` \ register1 ->
3833 getRegister y `thenNat` \ register2 ->
3834 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3835 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3837 code1 = registerCode register1 tmp1 []
3838 src1 = registerName register1 tmp1
3839 code2 = registerCode register2 tmp2 []
3840 src2 = registerName register2 tmp2
3841 code__2 dst = asmSeqThen [code1, code2] .
3842 mkSeqInstr (instr src1 (RIReg src2) dst)
3844 returnNat (Any IntRep code__2)
3847 trivialUCode instr x
3848 = getRegister x `thenNat` \ register ->
3849 getNewRegNCG IntRep `thenNat` \ tmp ->
3851 code = registerCode register tmp
3852 src = registerName register tmp
3853 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3855 returnNat (Any IntRep code__2)
3858 trivialFCode _ instr x y
3859 = getRegister x `thenNat` \ register1 ->
3860 getRegister y `thenNat` \ register2 ->
3861 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3862 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3864 code1 = registerCode register1 tmp1
3865 src1 = registerName register1 tmp1
3867 code2 = registerCode register2 tmp2
3868 src2 = registerName register2 tmp2
3870 code__2 dst = asmSeqThen [code1 [], code2 []] .
3871 mkSeqInstr (instr src1 src2 dst)
3873 returnNat (Any DoubleRep code__2)
3875 trivialUFCode _ instr x
3876 = getRegister x `thenNat` \ register ->
3877 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3879 code = registerCode register tmp
3880 src = registerName register tmp
3881 code__2 dst = code . mkSeqInstr (instr src dst)
3883 returnNat (Any DoubleRep code__2)
3885 #endif {- alpha_TARGET_ARCH -}
3887 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3889 #if i386_TARGET_ARCH
3891 The Rules of the Game are:
3893 * You cannot assume anything about the destination register dst;
3894 it may be anything, including a fixed reg.
3896 * You may compute an operand into a fixed reg, but you may not
3897 subsequently change the contents of that fixed reg. If you
3898 want to do so, first copy the value either to a temporary
3899 or into dst. You are free to modify dst even if it happens
3900 to be a fixed reg -- that's not your problem.
3902 * You cannot assume that a fixed reg will stay live over an
3903 arbitrary computation. The same applies to the dst reg.
3905 * Temporary regs obtained from getNewRegNCG are distinct from
3906 each other and from all other regs, and stay live over
3907 arbitrary computations.
3911 trivialCode instr maybe_revinstr a b
3914 = getRegister a `thenNat` \ rega ->
3917 then registerCode rega dst `bind` \ code_a ->
3919 instr (OpImm imm_b) (OpReg dst)
3920 else registerCodeF rega `bind` \ code_a ->
3921 registerNameF rega `bind` \ r_a ->
3923 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3924 instr (OpImm imm_b) (OpReg dst)
3926 returnNat (Any IntRep mkcode)
3929 = getRegister b `thenNat` \ regb ->
3930 getNewRegNCG IntRep `thenNat` \ tmp ->
3931 let revinstr_avail = maybeToBool maybe_revinstr
3932 revinstr = case maybe_revinstr of Just ri -> ri
3936 then registerCode regb dst `bind` \ code_b ->
3938 revinstr (OpImm imm_a) (OpReg dst)
3939 else registerCodeF regb `bind` \ code_b ->
3940 registerNameF regb `bind` \ r_b ->
3942 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3943 revinstr (OpImm imm_a) (OpReg dst)
3947 then registerCode regb tmp `bind` \ code_b ->
3949 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3950 instr (OpReg tmp) (OpReg dst)
3951 else registerCodeF regb `bind` \ code_b ->
3952 registerNameF regb `bind` \ r_b ->
3954 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3955 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3956 instr (OpReg tmp) (OpReg dst)
3958 returnNat (Any IntRep mkcode)
3961 = getRegister a `thenNat` \ rega ->
3962 getRegister b `thenNat` \ regb ->
3963 getNewRegNCG IntRep `thenNat` \ tmp ->
3965 = case (isAny rega, isAny regb) of
3967 -> registerCode regb tmp `bind` \ code_b ->
3968 registerCode rega dst `bind` \ code_a ->
3971 instr (OpReg tmp) (OpReg dst)
3973 -> registerCode rega tmp `bind` \ code_a ->
3974 registerCodeF regb `bind` \ code_b ->
3975 registerNameF regb `bind` \ r_b ->
3978 instr (OpReg r_b) (OpReg tmp) `snocOL`
3979 MOV L (OpReg tmp) (OpReg dst)
3981 -> registerCode regb tmp `bind` \ code_b ->
3982 registerCodeF rega `bind` \ code_a ->
3983 registerNameF rega `bind` \ r_a ->
3986 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3987 instr (OpReg tmp) (OpReg dst)
3989 -> registerCodeF rega `bind` \ code_a ->
3990 registerNameF rega `bind` \ r_a ->
3991 registerCodeF regb `bind` \ code_b ->
3992 registerNameF regb `bind` \ r_b ->
3994 MOV L (OpReg r_a) (OpReg tmp) `appOL`
3996 instr (OpReg r_b) (OpReg tmp) `snocOL`
3997 MOV L (OpReg tmp) (OpReg dst)
3999 returnNat (Any IntRep mkcode)
4002 maybe_imm_a = maybeImm a
4003 is_imm_a = maybeToBool maybe_imm_a
4004 imm_a = case maybe_imm_a of Just imm -> imm
4006 maybe_imm_b = maybeImm b
4007 is_imm_b = maybeToBool maybe_imm_b
4008 imm_b = case maybe_imm_b of Just imm -> imm
4012 trivialUCode instr x
4013 = getRegister x `thenNat` \ register ->
4015 code__2 dst = let code = registerCode register dst
4016 src = registerName register dst
4018 if isFixed register && dst /= src
4019 then toOL [MOV L (OpReg src) (OpReg dst),
4021 else unitOL (instr (OpReg src))
4023 returnNat (Any IntRep code__2)
4026 trivialFCode pk instr x y
4027 = getRegister x `thenNat` \ register1 ->
4028 getRegister y `thenNat` \ register2 ->
4029 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4030 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4032 code1 = registerCode register1 tmp1
4033 src1 = registerName register1 tmp1
4035 code2 = registerCode register2 tmp2
4036 src2 = registerName register2 tmp2
4039 -- treat the common case specially: both operands in
4041 | isAny register1 && isAny register2
4044 instr (primRepToSize pk) src1 src2 dst
4046 -- be paranoid (and inefficient)
4048 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4050 instr (primRepToSize pk) tmp1 src2 dst
4052 returnNat (Any pk code__2)
4056 trivialUFCode pk instr x
4057 = getRegister x `thenNat` \ register ->
4058 getNewRegNCG pk `thenNat` \ tmp ->
4060 code = registerCode register tmp
4061 src = registerName register tmp
4062 code__2 dst = code `snocOL` instr src dst
4064 returnNat (Any pk code__2)
4066 #endif {- i386_TARGET_ARCH -}
4068 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4070 #if sparc_TARGET_ARCH
4072 trivialCode instr x (StInt y)
4074 = getRegister x `thenNat` \ register ->
4075 getNewRegNCG IntRep `thenNat` \ tmp ->
4077 code = registerCode register tmp
4078 src1 = registerName register tmp
4079 src2 = ImmInt (fromInteger y)
4080 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4082 returnNat (Any IntRep code__2)
4084 trivialCode instr x y
4085 = getRegister x `thenNat` \ register1 ->
4086 getRegister y `thenNat` \ register2 ->
4087 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4088 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4090 code1 = registerCode register1 tmp1
4091 src1 = registerName register1 tmp1
4092 code2 = registerCode register2 tmp2
4093 src2 = registerName register2 tmp2
4094 code__2 dst = code1 `appOL` code2 `snocOL`
4095 instr src1 (RIReg src2) dst
4097 returnNat (Any IntRep code__2)
4100 trivialFCode pk instr x y
4101 = getRegister x `thenNat` \ register1 ->
4102 getRegister y `thenNat` \ register2 ->
4103 getNewRegNCG (registerRep register1)
4105 getNewRegNCG (registerRep register2)
4107 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4109 promote x = FxTOy F DF x tmp
4111 pk1 = registerRep register1
4112 code1 = registerCode register1 tmp1
4113 src1 = registerName register1 tmp1
4115 pk2 = registerRep register2
4116 code2 = registerCode register2 tmp2
4117 src2 = registerName register2 tmp2
4121 code1 `appOL` code2 `snocOL`
4122 instr (primRepToSize pk) src1 src2 dst
4123 else if pk1 == FloatRep then
4124 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4125 instr DF tmp src2 dst
4127 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4128 instr DF src1 tmp dst
4130 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4133 trivialUCode instr x
4134 = getRegister x `thenNat` \ register ->
4135 getNewRegNCG IntRep `thenNat` \ tmp ->
4137 code = registerCode register tmp
4138 src = registerName register tmp
4139 code__2 dst = code `snocOL` instr (RIReg src) dst
4141 returnNat (Any IntRep code__2)
4144 trivialUFCode pk instr x
4145 = getRegister x `thenNat` \ register ->
4146 getNewRegNCG pk `thenNat` \ tmp ->
4148 code = registerCode register tmp
4149 src = registerName register tmp
4150 code__2 dst = code `snocOL` instr src dst
4152 returnNat (Any pk code__2)
4154 #endif {- sparc_TARGET_ARCH -}
4156 #if powerpc_TARGET_ARCH
4157 trivialCode instr x (StInt y)
4159 = getRegister x `thenNat` \ register ->
4160 getNewRegNCG IntRep `thenNat` \ tmp ->
4162 code = registerCode register tmp
4163 src1 = registerName register tmp
4164 src2 = ImmInt (fromInteger y)
4165 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4167 returnNat (Any IntRep code__2)
4169 trivialCode instr x y
4170 = getRegister x `thenNat` \ register1 ->
4171 getRegister y `thenNat` \ register2 ->
4172 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4173 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4175 code1 = registerCode register1 tmp1
4176 src1 = registerName register1 tmp1
4177 code2 = registerCode register2 tmp2
4178 src2 = registerName register2 tmp2
4179 code__2 dst = code1 `appOL` code2 `snocOL`
4180 instr dst src1 (RIReg src2)
4182 returnNat (Any IntRep code__2)
4184 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4185 -> StixExpr -> StixExpr -> NatM Register
4186 trivialCode2 instr x y
4187 = getRegister x `thenNat` \ register1 ->
4188 getRegister y `thenNat` \ register2 ->
4189 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4190 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4192 code1 = registerCode register1 tmp1
4193 src1 = registerName register1 tmp1
4194 code2 = registerCode register2 tmp2
4195 src2 = registerName register2 tmp2
4196 code__2 dst = code1 `appOL` code2 `snocOL`
4199 returnNat (Any IntRep code__2)
4201 trivialFCode pk instr x y
4202 = getRegister x `thenNat` \ register1 ->
4203 getRegister y `thenNat` \ register2 ->
4204 getNewRegNCG (registerRep register1)
4206 getNewRegNCG (registerRep register2)
4208 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4210 -- promote x = FxTOy F DF x tmp
4212 pk1 = registerRep register1
4213 code1 = registerCode register1 tmp1
4214 src1 = registerName register1 tmp1
4216 pk2 = registerRep register2
4217 code2 = registerCode register2 tmp2
4218 src2 = registerName register2 tmp2
4222 code1 `appOL` code2 `snocOL`
4223 instr (primRepToSize pk) dst src1 src2
4224 else panic "###PPC MachCode.trivialFCode: type mismatch"
4226 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4228 trivialUCode instr x
4229 = getRegister x `thenNat` \ register ->
4230 getNewRegNCG IntRep `thenNat` \ tmp ->
4232 code = registerCode register tmp
4233 src = registerName register tmp
4234 code__2 dst = code `snocOL` instr dst src
4236 returnNat (Any IntRep code__2)
4237 trivialUFCode pk instr x = panic "###PPC MachCode.trivialUFCode"
4238 #endif {- powerpc_TARGET_ARCH -}
4240 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4243 %************************************************************************
4245 \subsubsection{Coercing to/from integer/floating-point...}
4247 %************************************************************************
4249 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4250 conversions. We have to store temporaries in memory to move
4251 between the integer and the floating point register sets.
4253 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4254 pretend, on sparc at least, that double and float regs are seperate
4255 kinds, so the value has to be computed into one kind before being
4256 explicitly "converted" to live in the other kind.
4259 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4260 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4262 coerceDbl2Flt :: StixExpr -> NatM Register
4263 coerceFlt2Dbl :: StixExpr -> NatM Register
4267 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4269 #if alpha_TARGET_ARCH
4272 = getRegister x `thenNat` \ register ->
4273 getNewRegNCG IntRep `thenNat` \ reg ->
4275 code = registerCode register reg
4276 src = registerName register reg
4278 code__2 dst = code . mkSeqInstrs [
4280 LD TF dst (spRel 0),
4283 returnNat (Any DoubleRep code__2)
4287 = getRegister x `thenNat` \ register ->
4288 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4290 code = registerCode register tmp
4291 src = registerName register tmp
4293 code__2 dst = code . mkSeqInstrs [
4295 ST TF tmp (spRel 0),
4298 returnNat (Any IntRep code__2)
4300 #endif {- alpha_TARGET_ARCH -}
4302 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4304 #if i386_TARGET_ARCH
4307 = getRegister x `thenNat` \ register ->
4308 getNewRegNCG IntRep `thenNat` \ reg ->
4310 code = registerCode register reg
4311 src = registerName register reg
4312 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4313 code__2 dst = code `snocOL` opc src dst
4315 returnNat (Any pk code__2)
4318 coerceFP2Int fprep x
4319 = getRegister x `thenNat` \ register ->
4320 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4322 code = registerCode register tmp
4323 src = registerName register tmp
4324 pk = registerRep register
4326 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4327 code__2 dst = code `snocOL` opc src dst
4329 returnNat (Any IntRep code__2)
4332 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4333 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4335 #endif {- i386_TARGET_ARCH -}
4337 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4339 #if sparc_TARGET_ARCH
4342 = getRegister x `thenNat` \ register ->
4343 getNewRegNCG IntRep `thenNat` \ reg ->
4345 code = registerCode register reg
4346 src = registerName register reg
4348 code__2 dst = code `appOL` toOL [
4349 ST W src (spRel (-2)),
4350 LD W (spRel (-2)) dst,
4351 FxTOy W (primRepToSize pk) dst dst]
4353 returnNat (Any pk code__2)
4356 coerceFP2Int fprep x
4357 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4358 getRegister x `thenNat` \ register ->
4359 getNewRegNCG fprep `thenNat` \ reg ->
4360 getNewRegNCG FloatRep `thenNat` \ tmp ->
4362 code = registerCode register reg
4363 src = registerName register reg
4364 code__2 dst = code `appOL` toOL [
4365 FxTOy (primRepToSize fprep) W src tmp,
4366 ST W tmp (spRel (-2)),
4367 LD W (spRel (-2)) dst]
4369 returnNat (Any IntRep code__2)
4373 = getRegister x `thenNat` \ register ->
4374 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4375 let code = registerCode register tmp
4376 src = registerName register tmp
4378 returnNat (Any FloatRep
4379 (\dst -> code `snocOL` FxTOy DF F src dst))
4383 = getRegister x `thenNat` \ register ->
4384 getNewRegNCG FloatRep `thenNat` \ tmp ->
4385 let code = registerCode register tmp
4386 src = registerName register tmp
4388 returnNat (Any DoubleRep
4389 (\dst -> code `snocOL` FxTOy F DF src dst))
4391 #endif {- sparc_TARGET_ARCH -}
4393 #if powerpc_TARGET_ARCH
4394 coerceInt2FP pk x = panic "###PPC MachCode.coerceInt2FP"
4395 coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int"
4396 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4397 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4398 #endif {- powerpc_TARGET_ARCH -}
4400 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -