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 )
54 import Maybe ( fromMaybe )
57 import Outputable ( assertPanic )
59 import TRACE ( trace )
64 @InstrBlock@s are the insn sequences generated by the insn selectors.
65 They are really trees of insns to facilitate fast appending, where a
66 left-to-right traversal (pre-order?) yields the insns in the correct
70 type InstrBlock = OrdList Instr
74 isLeft (Left _) = True
75 isLeft (Right _) = False
80 Code extractor for an entire stix tree---stix statement level.
83 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
85 = mapNat stmtToInstrs stmts `thenNat` \ instrss ->
86 returnNat (concatOL instrss)
89 stmtToInstrs :: StixStmt -> NatM InstrBlock
90 stmtToInstrs stmt = case stmt of
91 StComment s -> returnNat (unitOL (COMMENT s))
92 StSegment seg -> returnNat (unitOL (SEGMENT seg))
94 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
96 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
99 StLabel lab -> returnNat (unitOL (LABEL lab))
101 StJump dsts arg -> genJump dsts (derefDLL arg)
102 StCondJump lab arg -> genCondJump lab (derefDLL arg)
104 -- A call returning void, ie one done for its side-effects. Note
105 -- that this is the only StVoidable we handle.
106 StVoidable (StCall fn cconv VoidRep args)
107 -> genCCall fn cconv VoidRep (map derefDLL args)
109 StAssignMem pk addr src
110 | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
111 | ncg_target_is_32bit
112 && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src)
113 | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
114 StAssignReg pk reg src
115 | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
116 | ncg_target_is_32bit
117 && is64BitRep pk -> assignReg_I64Code reg (derefDLL src)
118 | otherwise -> assignReg_IntCode pk reg (derefDLL src)
121 -- When falling through on the Alpha, we still have to load pv
122 -- with the address of the next routine, so that it can load gp.
123 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
127 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
128 returnNat (DATA (primRepToSize kind) imms
129 `consOL` concatOL codes)
131 getData :: StixExpr -> NatM (InstrBlock, Imm)
132 getData (StInt i) = returnNat (nilOL, ImmInteger i)
133 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
134 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
135 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
136 getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString"
137 -- the linker can handle simple arithmetic...
138 getData (StIndex rep (StCLbl lbl) (StInt off)) =
140 ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
142 -- Top-level lifted-out string. The segment will already have been set
143 -- (see Stix.liftStrings).
145 -> returnNat (unitOL (ASCII True (unpackFS str)))
148 other -> pprPanic "stmtToInstrs" (pprStixStmt other)
151 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
152 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
153 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
155 derefDLL :: StixExpr -> StixExpr
157 | opt_Static -- short out the entire deal if not doing DLLs
164 StCLbl lbl -> if labelDynamic lbl
165 then StInd PtrRep (StCLbl lbl)
167 -- all the rest are boring
168 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
169 StMachOp mop args -> StMachOp mop (map qq args)
170 StInd pk addr -> StInd pk (qq addr)
171 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
172 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
178 _ -> pprPanic "derefDLL: unhandled case"
182 %************************************************************************
184 \subsection{General things for putting together code sequences}
186 %************************************************************************
189 mangleIndexTree :: StixExpr -> StixExpr
191 mangleIndexTree (StIndex pk base (StInt i))
192 = StMachOp MO_Nat_Add [base, off]
194 off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
196 mangleIndexTree (StIndex pk base off)
197 = StMachOp MO_Nat_Add [
200 in if s == 0 then off
201 else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
204 shift :: PrimRep -> Int
205 shift rep = case getPrimRepSizeInBytes rep of
210 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size"
211 (Outputable.int other)
215 maybeImm :: StixExpr -> Maybe Imm
219 maybeImm (StIndex rep (StCLbl l) (StInt off))
220 = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
222 | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
223 = Just (ImmInt (fromInteger i))
225 = Just (ImmInteger i)
230 %************************************************************************
232 \subsection{The @Register64@ type}
234 %************************************************************************
236 Simple support for generating 64-bit code (ie, 64 bit values and 64
237 bit assignments) on 32-bit platforms. Unlike the main code generator
238 we merely shoot for generating working code as simply as possible, and
239 pay little attention to code quality. Specifically, there is no
240 attempt to deal cleverly with the fixed-vs-floating register
241 distinction; all values are generated into (pairs of) floating
242 registers, even if this would mean some redundant reg-reg moves as a
243 result. Only one of the VRegUniques is returned, since it will be
244 of the VRegUniqueLo form, and the upper-half VReg can be determined
245 by applying getHiVRegFromLo to it.
249 data ChildCode64 -- a.k.a "Register64"
252 VRegUnique -- unique for the lower 32-bit temporary
253 -- which contains the result; use getHiVRegFromLo to find
254 -- the other VRegUnique.
255 -- Rules of this simplified insn selection game are
256 -- therefore that the returned VRegUnique may be modified
258 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
259 assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock
260 iselExpr64 :: StixExpr -> NatM ChildCode64
262 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
266 assignMem_I64Code addrTree valueTree
267 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
268 getRegister addrTree `thenNat` \ register_addr ->
269 getNewRegNCG IntRep `thenNat` \ t_addr ->
270 let rlo = VirtualRegI vrlo
271 rhi = getHiVRegFromLo rlo
272 code_addr = registerCode register_addr t_addr
273 reg_addr = registerName register_addr t_addr
274 -- Little-endian store
275 mov_lo = MOV L (OpReg rlo)
276 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
277 mov_hi = MOV L (OpReg rhi)
278 (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
280 returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
282 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
283 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
285 r_dst_lo = mkVReg u_dst IntRep
286 r_src_lo = VirtualRegI vr_src_lo
287 r_dst_hi = getHiVRegFromLo r_dst_lo
288 r_src_hi = getHiVRegFromLo r_src_lo
289 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
290 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
293 vcode `snocOL` mov_lo `snocOL` mov_hi
296 assignReg_I64Code lvalue valueTree
297 = pprPanic "assignReg_I64Code(i386): invalid lvalue"
302 iselExpr64 (StInd pk addrTree)
304 = getRegister addrTree `thenNat` \ register_addr ->
305 getNewRegNCG IntRep `thenNat` \ t_addr ->
306 getNewRegNCG IntRep `thenNat` \ rlo ->
307 let rhi = getHiVRegFromLo rlo
308 code_addr = registerCode register_addr t_addr
309 reg_addr = registerName register_addr t_addr
310 mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
312 mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
316 ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi)
320 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
322 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
323 let r_dst_hi = getHiVRegFromLo r_dst_lo
324 r_src_lo = mkVReg vu IntRep
325 r_src_hi = getHiVRegFromLo r_src_lo
326 mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
327 mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
330 ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
333 iselExpr64 (StCall fn cconv kind args)
335 = genCCall fn cconv kind args `thenNat` \ call ->
336 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
337 let r_dst_hi = getHiVRegFromLo r_dst_lo
338 mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
339 mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
342 ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi)
343 (getVRegUnique r_dst_lo)
347 = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
349 #endif /* i386_TARGET_ARCH */
351 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
353 #if sparc_TARGET_ARCH
355 assignMem_I64Code addrTree valueTree
356 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
357 getRegister addrTree `thenNat` \ register_addr ->
358 getNewRegNCG IntRep `thenNat` \ t_addr ->
359 let rlo = VirtualRegI vrlo
360 rhi = getHiVRegFromLo rlo
361 code_addr = registerCode register_addr t_addr
362 reg_addr = registerName register_addr t_addr
364 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
365 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
367 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
370 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
371 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
373 r_dst_lo = mkVReg u_dst IntRep
374 r_src_lo = VirtualRegI vr_src_lo
375 r_dst_hi = getHiVRegFromLo r_dst_lo
376 r_src_hi = getHiVRegFromLo r_src_lo
377 mov_lo = mkMOV r_src_lo r_dst_lo
378 mov_hi = mkMOV r_src_hi r_dst_hi
379 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
382 vcode `snocOL` mov_hi `snocOL` mov_lo
384 assignReg_I64Code lvalue valueTree
385 = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
389 -- Don't delete this -- it's very handy for debugging.
391 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
392 -- = panic "iselExpr64(???)"
394 iselExpr64 (StInd pk addrTree)
396 = getRegister addrTree `thenNat` \ register_addr ->
397 getNewRegNCG IntRep `thenNat` \ t_addr ->
398 getNewRegNCG IntRep `thenNat` \ rlo ->
399 let rhi = getHiVRegFromLo rlo
400 code_addr = registerCode register_addr t_addr
401 reg_addr = registerName register_addr t_addr
402 mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
403 mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
406 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
410 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
412 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
413 let r_dst_hi = getHiVRegFromLo r_dst_lo
414 r_src_lo = mkVReg vu IntRep
415 r_src_hi = getHiVRegFromLo r_src_lo
416 mov_lo = mkMOV r_src_lo r_dst_lo
417 mov_hi = mkMOV r_src_hi r_dst_hi
418 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
421 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
424 iselExpr64 (StCall fn cconv kind args)
426 = genCCall fn cconv kind args `thenNat` \ call ->
427 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
428 let r_dst_hi = getHiVRegFromLo r_dst_lo
429 mov_lo = mkMOV o0 r_dst_lo
430 mov_hi = mkMOV o1 r_dst_hi
431 mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
434 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
435 (getVRegUnique r_dst_lo)
439 = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
441 #endif /* sparc_TARGET_ARCH */
442 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
444 #if powerpc_TARGET_ARCH
446 assignMem_I64Code addrTree valueTree
447 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
448 getRegister addrTree `thenNat` \ register_addr ->
449 getNewRegNCG IntRep `thenNat` \ t_addr ->
450 let rlo = VirtualRegI vrlo
451 rhi = getHiVRegFromLo rlo
452 code_addr = registerCode register_addr t_addr
453 reg_addr = registerName register_addr t_addr
455 mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
456 mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
458 returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
461 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
462 = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
464 r_dst_lo = mkVReg u_dst IntRep
465 r_src_lo = VirtualRegI vr_src_lo
466 r_dst_hi = getHiVRegFromLo r_dst_lo
467 r_src_hi = getHiVRegFromLo r_src_lo
468 mov_lo = MR r_dst_lo r_src_lo
469 mov_hi = MR r_dst_hi r_src_hi
472 vcode `snocOL` mov_hi `snocOL` mov_lo
474 assignReg_I64Code lvalue valueTree
475 = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
479 -- Don't delete this -- it's very handy for debugging.
481 -- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
482 -- = panic "iselExpr64(???)"
484 iselExpr64 (StInd pk addrTree)
486 = getRegister addrTree `thenNat` \ register_addr ->
487 getNewRegNCG IntRep `thenNat` \ t_addr ->
488 getNewRegNCG IntRep `thenNat` \ rlo ->
489 let rhi = getHiVRegFromLo rlo
490 code_addr = registerCode register_addr t_addr
491 reg_addr = registerName register_addr t_addr
492 mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
493 mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
496 ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
500 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
502 = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
503 let r_dst_hi = getHiVRegFromLo r_dst_lo
504 r_src_lo = mkVReg vu IntRep
505 r_src_hi = getHiVRegFromLo r_src_lo
506 mov_lo = MR r_dst_lo r_src_lo
507 mov_hi = MR r_dst_hi r_src_hi
510 ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
513 iselExpr64 (StCall fn cconv kind args)
515 = genCCall fn cconv kind args `thenNat` \ call ->
516 getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
517 let r_dst_hi = getHiVRegFromLo r_dst_lo
518 mov_lo = MR r_dst_lo r4
519 mov_hi = MR r_dst_hi r3
522 ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
523 (getVRegUnique r_dst_lo)
527 = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
529 #endif /* powerpc_TARGET_ARCH */
531 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
535 %************************************************************************
537 \subsection{The @Register@ type}
539 %************************************************************************
541 @Register@s passed up the tree. If the stix code forces the register
542 to live in a pre-decided machine register, it comes out as @Fixed@;
543 otherwise, it comes out as @Any@, and the parent can decide which
544 register to put it in.
548 = Fixed PrimRep Reg InstrBlock
549 | Any PrimRep (Reg -> InstrBlock)
551 registerCode :: Register -> Reg -> InstrBlock
552 registerCode (Fixed _ _ code) reg = code
553 registerCode (Any _ code) reg = code reg
555 registerCodeF (Fixed _ _ code) = code
556 registerCodeF (Any _ _) = panic "registerCodeF"
558 registerCodeA (Any _ code) = code
559 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
561 registerName :: Register -> Reg -> Reg
562 registerName (Fixed _ reg _) _ = reg
563 registerName (Any _ _) reg = reg
565 registerNameF (Fixed _ reg _) = reg
566 registerNameF (Any _ _) = panic "registerNameF"
568 registerRep :: Register -> PrimRep
569 registerRep (Fixed pk _ _) = pk
570 registerRep (Any pk _) = pk
572 swizzleRegisterRep :: Register -> PrimRep -> Register
573 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
574 swizzleRegisterRep (Any _ codefn) rep = Any rep codefn
576 {-# INLINE registerCode #-}
577 {-# INLINE registerCodeF #-}
578 {-# INLINE registerName #-}
579 {-# INLINE registerNameF #-}
580 {-# INLINE registerRep #-}
581 {-# INLINE isFixed #-}
584 isFixed, isAny :: Register -> Bool
585 isFixed (Fixed _ _ _) = True
586 isFixed (Any _ _) = False
588 isAny = not . isFixed
591 Generate code to get a subtree into a @Register@:
594 getRegisterReg :: StixReg -> NatM Register
595 getRegister :: StixExpr -> NatM Register
598 getRegisterReg (StixMagicId mid)
599 = case get_MagicId_reg_or_addr mid of
601 -> let pk = magicIdPrimRep mid
602 in returnNat (Fixed pk (RealReg rrno) nilOL)
604 -- By this stage, the only MagicIds remaining should be the
605 -- ones which map to a real machine register on this platform. Hence ...
606 -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
608 getRegisterReg (StixTemp (StixVReg u pk))
609 = returnNat (Fixed pk (mkVReg u pk) nilOL)
613 -- Don't delete this -- it's very handy for debugging.
615 -- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
616 -- = panic "getRegister(???)"
618 getRegister (StReg reg)
621 getRegister tree@(StIndex _ _ _)
622 = getRegister (mangleIndexTree tree)
624 getRegister (StCall fn cconv kind args)
625 | not (ncg_target_is_32bit && is64BitRep kind)
626 = genCCall fn cconv kind args `thenNat` \ call ->
627 returnNat (Fixed kind reg call)
629 reg = if isFloatingRep kind
630 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
631 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
633 getRegister (StString s)
634 = getNatLabelNCG `thenNat` \ lbl ->
636 imm_lbl = ImmCLbl lbl
639 SEGMENT RoDataSegment,
641 ASCII True (unpackFS s),
643 #if alpha_TARGET_ARCH
644 LDA dst (AddrImm imm_lbl)
647 MOV L (OpImm imm_lbl) (OpReg dst)
649 #if sparc_TARGET_ARCH
650 SETHI (HI imm_lbl) dst,
651 OR False dst (RIImm (LO imm_lbl)) dst
653 #if powerpc_TARGET_ARCH
654 LIS dst (HI imm_lbl),
655 OR dst dst (RIImm (LO imm_lbl))
659 returnNat (Any PtrRep code)
661 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
662 -- end of machine-"independent" bit; here we go on the rest...
664 #if alpha_TARGET_ARCH
666 getRegister (StDouble d)
667 = getNatLabelNCG `thenNat` \ lbl ->
668 getNewRegNCG PtrRep `thenNat` \ tmp ->
669 let code dst = mkSeqInstrs [
672 DATA TF [ImmLab (rational d)],
674 LDA tmp (AddrImm (ImmCLbl lbl)),
675 LD TF dst (AddrReg tmp)]
677 returnNat (Any DoubleRep code)
679 getRegister (StPrim primop [x]) -- unary PrimOps
681 IntNegOp -> trivialUCode (NEG Q False) x
683 NotOp -> trivialUCode NOT x
685 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
686 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
688 OrdOp -> coerceIntCode IntRep x
691 Float2IntOp -> coerceFP2Int x
692 Int2FloatOp -> coerceInt2FP pr x
693 Double2IntOp -> coerceFP2Int x
694 Int2DoubleOp -> coerceInt2FP pr x
696 Double2FloatOp -> coerceFltCode x
697 Float2DoubleOp -> coerceFltCode x
699 other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
701 fn = case other_op of
702 FloatExpOp -> FSLIT("exp")
703 FloatLogOp -> FSLIT("log")
704 FloatSqrtOp -> FSLIT("sqrt")
705 FloatSinOp -> FSLIT("sin")
706 FloatCosOp -> FSLIT("cos")
707 FloatTanOp -> FSLIT("tan")
708 FloatAsinOp -> FSLIT("asin")
709 FloatAcosOp -> FSLIT("acos")
710 FloatAtanOp -> FSLIT("atan")
711 FloatSinhOp -> FSLIT("sinh")
712 FloatCoshOp -> FSLIT("cosh")
713 FloatTanhOp -> FSLIT("tanh")
714 DoubleExpOp -> FSLIT("exp")
715 DoubleLogOp -> FSLIT("log")
716 DoubleSqrtOp -> FSLIT("sqrt")
717 DoubleSinOp -> FSLIT("sin")
718 DoubleCosOp -> FSLIT("cos")
719 DoubleTanOp -> FSLIT("tan")
720 DoubleAsinOp -> FSLIT("asin")
721 DoubleAcosOp -> FSLIT("acos")
722 DoubleAtanOp -> FSLIT("atan")
723 DoubleSinhOp -> FSLIT("sinh")
724 DoubleCoshOp -> FSLIT("cosh")
725 DoubleTanhOp -> FSLIT("tanh")
727 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
729 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
731 CharGtOp -> trivialCode (CMP LTT) y x
732 CharGeOp -> trivialCode (CMP LE) y x
733 CharEqOp -> trivialCode (CMP EQQ) x y
734 CharNeOp -> int_NE_code x y
735 CharLtOp -> trivialCode (CMP LTT) x y
736 CharLeOp -> trivialCode (CMP LE) x y
738 IntGtOp -> trivialCode (CMP LTT) y x
739 IntGeOp -> trivialCode (CMP LE) y x
740 IntEqOp -> trivialCode (CMP EQQ) x y
741 IntNeOp -> int_NE_code x y
742 IntLtOp -> trivialCode (CMP LTT) x y
743 IntLeOp -> trivialCode (CMP LE) x y
745 WordGtOp -> trivialCode (CMP ULT) y x
746 WordGeOp -> trivialCode (CMP ULE) x y
747 WordEqOp -> trivialCode (CMP EQQ) x y
748 WordNeOp -> int_NE_code x y
749 WordLtOp -> trivialCode (CMP ULT) x y
750 WordLeOp -> trivialCode (CMP ULE) x y
752 AddrGtOp -> trivialCode (CMP ULT) y x
753 AddrGeOp -> trivialCode (CMP ULE) y x
754 AddrEqOp -> trivialCode (CMP EQQ) x y
755 AddrNeOp -> int_NE_code x y
756 AddrLtOp -> trivialCode (CMP ULT) x y
757 AddrLeOp -> trivialCode (CMP ULE) x y
759 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
760 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
761 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
762 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
763 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
764 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
766 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
767 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
768 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
769 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
770 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
771 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
773 IntAddOp -> trivialCode (ADD Q False) x y
774 IntSubOp -> trivialCode (SUB Q False) x y
775 IntMulOp -> trivialCode (MUL Q False) x y
776 IntQuotOp -> trivialCode (DIV Q False) x y
777 IntRemOp -> trivialCode (REM Q False) x y
779 WordAddOp -> trivialCode (ADD Q False) x y
780 WordSubOp -> trivialCode (SUB Q False) x y
781 WordMulOp -> trivialCode (MUL Q False) x y
782 WordQuotOp -> trivialCode (DIV Q True) x y
783 WordRemOp -> trivialCode (REM Q True) x y
785 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
786 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
787 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
788 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
790 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
791 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
792 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
793 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
795 AddrAddOp -> trivialCode (ADD Q False) x y
796 AddrSubOp -> trivialCode (SUB Q False) x y
797 AddrRemOp -> trivialCode (REM Q True) x y
799 AndOp -> trivialCode AND x y
800 OrOp -> trivialCode OR x y
801 XorOp -> trivialCode XOR x y
802 SllOp -> trivialCode SLL x y
803 SrlOp -> trivialCode SRL x y
805 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
806 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
807 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
809 FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
810 DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
812 {- ------------------------------------------------------------
813 Some bizarre special code for getting condition codes into
814 registers. Integer non-equality is a test for equality
815 followed by an XOR with 1. (Integer comparisons always set
816 the result register to 0 or 1.) Floating point comparisons of
817 any kind leave the result in a floating point register, so we
818 need to wrangle an integer register out of things.
820 int_NE_code :: StixTree -> StixTree -> NatM Register
823 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
824 getNewRegNCG IntRep `thenNat` \ tmp ->
826 code = registerCode register tmp
827 src = registerName register tmp
828 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
830 returnNat (Any IntRep code__2)
832 {- ------------------------------------------------------------
833 Comments for int_NE_code also apply to cmpF_code
836 :: (Reg -> Reg -> Reg -> Instr)
838 -> StixTree -> StixTree
841 cmpF_code instr cond x y
842 = trivialFCode pr instr x y `thenNat` \ register ->
843 getNewRegNCG DoubleRep `thenNat` \ tmp ->
844 getNatLabelNCG `thenNat` \ lbl ->
846 code = registerCode register tmp
847 result = registerName register tmp
849 code__2 dst = code . mkSeqInstrs [
850 OR zeroh (RIImm (ImmInt 1)) dst,
851 BF cond result (ImmCLbl lbl),
852 OR zeroh (RIReg zeroh) dst,
855 returnNat (Any IntRep code__2)
857 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
858 ------------------------------------------------------------
860 getRegister (StInd pk mem)
861 = getAmode mem `thenNat` \ amode ->
863 code = amodeCode amode
864 src = amodeAddr amode
865 size = primRepToSize pk
866 code__2 dst = code . mkSeqInstr (LD size dst src)
868 returnNat (Any pk code__2)
870 getRegister (StInt i)
873 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
875 returnNat (Any IntRep code)
878 code dst = mkSeqInstr (LDI Q dst src)
880 returnNat (Any IntRep code)
882 src = ImmInt (fromInteger i)
887 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
889 returnNat (Any PtrRep code)
892 imm__2 = case imm of Just x -> x
894 #endif /* alpha_TARGET_ARCH */
896 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
900 getRegister (StFloat f)
901 = getNatLabelNCG `thenNat` \ lbl ->
902 let code dst = toOL [
907 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
910 returnNat (Any FloatRep code)
913 getRegister (StDouble d)
916 = let code dst = unitOL (GLDZ dst)
917 in returnNat (Any DoubleRep code)
920 = let code dst = unitOL (GLD1 dst)
921 in returnNat (Any DoubleRep code)
924 = getNatLabelNCG `thenNat` \ lbl ->
925 let code dst = toOL [
928 DATA DF [ImmDouble d],
930 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
933 returnNat (Any DoubleRep code)
936 getRegister (StMachOp mop [x]) -- unary MachOps
938 MO_NatS_Neg -> trivialUCode (NEGI L) x
939 MO_Nat_Not -> trivialUCode (NOT L) x
940 MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
942 MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x
943 MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x
945 MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x
946 MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
948 MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x
949 MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x
951 MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x
952 MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x
954 MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x
955 MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x
957 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
958 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
959 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
960 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
962 -- Conversions which are a nop on x86
963 MO_32U_to_NatS -> conversionNop IntRep x
964 MO_32S_to_NatS -> conversionNop IntRep x
965 MO_NatS_to_32U -> conversionNop WordRep x
966 MO_32U_to_NatU -> conversionNop WordRep x
968 MO_NatU_to_NatS -> conversionNop IntRep x
969 MO_NatS_to_NatU -> conversionNop WordRep x
970 MO_NatP_to_NatU -> conversionNop WordRep x
971 MO_NatU_to_NatP -> conversionNop PtrRep x
972 MO_NatS_to_NatP -> conversionNop PtrRep x
973 MO_NatP_to_NatS -> conversionNop IntRep x
975 MO_Dbl_to_Flt -> conversionNop FloatRep x
976 MO_Flt_to_Dbl -> conversionNop DoubleRep x
978 -- sign-extending widenings
979 MO_8U_to_NatU -> integerExtend False 24 x
980 MO_8S_to_NatS -> integerExtend True 24 x
981 MO_16U_to_NatU -> integerExtend False 16 x
982 MO_16S_to_NatS -> integerExtend True 16 x
983 MO_8U_to_32U -> integerExtend False 24 x
987 (if is_float_op then demote else id)
988 (StCall (Left fn) CCallConv DoubleRep
989 [(if is_float_op then promote else id) x])
992 integerExtend signed nBits x
994 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
995 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
998 conversionNop new_rep expr
999 = getRegister expr `thenNat` \ e_code ->
1000 returnNat (swizzleRegisterRep e_code new_rep)
1002 promote x = StMachOp MO_Flt_to_Dbl [x]
1003 demote x = StMachOp MO_Dbl_to_Flt [x]
1006 MO_Flt_Exp -> (True, FSLIT("exp"))
1007 MO_Flt_Log -> (True, FSLIT("log"))
1009 MO_Flt_Asin -> (True, FSLIT("asin"))
1010 MO_Flt_Acos -> (True, FSLIT("acos"))
1011 MO_Flt_Atan -> (True, FSLIT("atan"))
1013 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1014 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1015 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1017 MO_Dbl_Exp -> (False, FSLIT("exp"))
1018 MO_Dbl_Log -> (False, FSLIT("log"))
1020 MO_Dbl_Asin -> (False, FSLIT("asin"))
1021 MO_Dbl_Acos -> (False, FSLIT("acos"))
1022 MO_Dbl_Atan -> (False, FSLIT("atan"))
1024 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1025 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1026 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1028 other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
1032 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
1034 MO_32U_Gt -> condIntReg GTT x y
1035 MO_32U_Ge -> condIntReg GE x y
1036 MO_32U_Eq -> condIntReg EQQ x y
1037 MO_32U_Ne -> condIntReg NE x y
1038 MO_32U_Lt -> condIntReg LTT x y
1039 MO_32U_Le -> condIntReg LE x y
1041 MO_Nat_Eq -> condIntReg EQQ x y
1042 MO_Nat_Ne -> condIntReg NE x y
1044 MO_NatS_Gt -> condIntReg GTT x y
1045 MO_NatS_Ge -> condIntReg GE x y
1046 MO_NatS_Lt -> condIntReg LTT x y
1047 MO_NatS_Le -> condIntReg LE x y
1049 MO_NatU_Gt -> condIntReg GU x y
1050 MO_NatU_Ge -> condIntReg GEU x y
1051 MO_NatU_Lt -> condIntReg LU x y
1052 MO_NatU_Le -> condIntReg LEU x y
1054 MO_Flt_Gt -> condFltReg GTT x y
1055 MO_Flt_Ge -> condFltReg GE x y
1056 MO_Flt_Eq -> condFltReg EQQ x y
1057 MO_Flt_Ne -> condFltReg NE x y
1058 MO_Flt_Lt -> condFltReg LTT x y
1059 MO_Flt_Le -> condFltReg LE x y
1061 MO_Dbl_Gt -> condFltReg GTT x y
1062 MO_Dbl_Ge -> condFltReg GE x y
1063 MO_Dbl_Eq -> condFltReg EQQ x y
1064 MO_Dbl_Ne -> condFltReg NE x y
1065 MO_Dbl_Lt -> condFltReg LTT x y
1066 MO_Dbl_Le -> condFltReg LE x y
1068 MO_Nat_Add -> add_code L x y
1069 MO_Nat_Sub -> sub_code L x y
1070 MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
1071 MO_NatS_Rem -> trivialCode (IREM L) Nothing x y
1072 MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
1073 MO_NatU_Rem -> trivialCode (REM L) Nothing x y
1074 MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y
1075 MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y
1076 MO_NatS_MulMayOflo -> imulMayOflo x y
1078 MO_Flt_Add -> trivialFCode FloatRep GADD x y
1079 MO_Flt_Sub -> trivialFCode FloatRep GSUB x y
1080 MO_Flt_Mul -> trivialFCode FloatRep GMUL x y
1081 MO_Flt_Div -> trivialFCode FloatRep GDIV x y
1083 MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
1084 MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
1085 MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
1086 MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
1088 MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
1089 MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y
1090 MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1092 {- Shift ops on x86s have constraints on their source, it
1093 either has to be Imm, CL or 1
1094 => trivialCode's is not restrictive enough (sigh.)
1096 MO_Nat_Shl -> shift_code (SHL L) x y {-False-}
1097 MO_Nat_Shr -> shift_code (SHR L) x y {-False-}
1098 MO_Nat_Sar -> shift_code (SAR L) x y {-False-}
1100 MO_Flt_Pwr -> getRegister (demote
1101 (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1102 [promote x, promote y])
1104 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1106 other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1108 promote x = StMachOp MO_Flt_to_Dbl [x]
1109 demote x = StMachOp MO_Dbl_to_Flt [x]
1111 --------------------
1112 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1114 = getNewRegNCG IntRep `thenNat` \ t1 ->
1115 getNewRegNCG IntRep `thenNat` \ t2 ->
1116 getNewRegNCG IntRep `thenNat` \ res_lo ->
1117 getNewRegNCG IntRep `thenNat` \ res_hi ->
1118 getRegister a1 `thenNat` \ reg1 ->
1119 getRegister a2 `thenNat` \ reg2 ->
1120 let code1 = registerCode reg1 t1
1121 code2 = registerCode reg2 t2
1122 src1 = registerName reg1 t1
1123 src2 = registerName reg2 t2
1124 code dst = code1 `appOL` code2 `appOL`
1126 MOV L (OpReg src1) (OpReg res_hi),
1127 MOV L (OpReg src2) (OpReg res_lo),
1128 IMUL64 res_hi res_lo, -- result in res_hi:res_lo
1129 SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part
1130 SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1131 MOV L (OpReg res_lo) (OpReg dst)
1132 -- dst==0 if high part == sign extended low part
1135 returnNat (Any IntRep code)
1137 --------------------
1138 shift_code :: (Imm -> Operand -> Instr)
1143 {- Case1: shift length as immediate -}
1144 -- Code is the same as the first eq. for trivialCode -- sigh.
1145 shift_code instr x y{-amount-}
1147 = getRegister x `thenNat` \ regx ->
1150 then registerCodeA regx dst `bind` \ code_x ->
1152 instr imm__2 (OpReg dst)
1153 else registerCodeF regx `bind` \ code_x ->
1154 registerNameF regx `bind` \ r_x ->
1156 MOV L (OpReg r_x) (OpReg dst) `snocOL`
1157 instr imm__2 (OpReg dst)
1159 returnNat (Any IntRep mkcode)
1162 imm__2 = case imm of Just x -> x
1164 {- Case2: shift length is complex (non-immediate) -}
1165 -- Since ECX is always used as a spill temporary, we can't
1166 -- use it here to do non-immediate shifts. No big deal --
1167 -- they are only very rare, and we can use an equivalent
1168 -- test-and-jump sequence which doesn't use ECX.
1169 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1170 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1171 shift_code instr x y{-amount-}
1172 = getRegister x `thenNat` \ register1 ->
1173 getRegister y `thenNat` \ register2 ->
1174 getNatLabelNCG `thenNat` \ lbl_test3 ->
1175 getNatLabelNCG `thenNat` \ lbl_test2 ->
1176 getNatLabelNCG `thenNat` \ lbl_test1 ->
1177 getNatLabelNCG `thenNat` \ lbl_test0 ->
1178 getNatLabelNCG `thenNat` \ lbl_after ->
1179 getNewRegNCG IntRep `thenNat` \ tmp ->
1181 = let src_val = registerName register1 dst
1182 code_val = registerCode register1 dst
1183 src_amt = registerName register2 tmp
1184 code_amt = registerCode register2 tmp
1189 MOV L (OpReg src_amt) r_tmp `appOL`
1191 MOV L (OpReg src_val) r_dst `appOL`
1193 COMMENT (mkFastString "begin shift sequence"),
1194 MOV L (OpReg src_val) r_dst,
1195 MOV L (OpReg src_amt) r_tmp,
1197 BT L (ImmInt 4) r_tmp,
1199 instr (ImmInt 16) r_dst,
1202 BT L (ImmInt 3) r_tmp,
1204 instr (ImmInt 8) r_dst,
1207 BT L (ImmInt 2) r_tmp,
1209 instr (ImmInt 4) r_dst,
1212 BT L (ImmInt 1) r_tmp,
1214 instr (ImmInt 2) r_dst,
1217 BT L (ImmInt 0) r_tmp,
1219 instr (ImmInt 1) r_dst,
1222 COMMENT (mkFastString "end shift sequence")
1225 returnNat (Any IntRep code__2)
1227 --------------------
1228 add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1230 add_code sz x (StInt y)
1231 = getRegister x `thenNat` \ register ->
1232 getNewRegNCG IntRep `thenNat` \ tmp ->
1234 code = registerCode register tmp
1235 src1 = registerName register tmp
1236 src2 = ImmInt (fromInteger y)
1239 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1242 returnNat (Any IntRep code__2)
1244 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1246 --------------------
1247 sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1249 sub_code sz x (StInt y)
1250 = getRegister x `thenNat` \ register ->
1251 getNewRegNCG IntRep `thenNat` \ tmp ->
1253 code = registerCode register tmp
1254 src1 = registerName register tmp
1255 src2 = ImmInt (-(fromInteger y))
1258 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1261 returnNat (Any IntRep code__2)
1263 sub_code sz x y = trivialCode (SUB sz) Nothing x y
1265 getRegister (StInd pk mem)
1266 | not (is64BitRep pk)
1267 = getAmode mem `thenNat` \ amode ->
1269 code = amodeCode amode
1270 src = amodeAddr amode
1271 size = primRepToSize pk
1272 code__2 dst = code `snocOL`
1273 if pk == DoubleRep || pk == FloatRep
1274 then GLD size src dst
1282 (OpAddr src) (OpReg dst)
1284 returnNat (Any pk code__2)
1286 getRegister (StInt i)
1288 src = ImmInt (fromInteger i)
1291 = unitOL (XOR L (OpReg dst) (OpReg dst))
1293 = unitOL (MOV L (OpImm src) (OpReg dst))
1295 returnNat (Any IntRep code)
1299 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1301 returnNat (Any PtrRep code)
1303 = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1306 imm__2 = case imm of Just x -> x
1308 #endif /* i386_TARGET_ARCH */
1310 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1312 #if sparc_TARGET_ARCH
1314 getRegister (StFloat d)
1315 = getNatLabelNCG `thenNat` \ lbl ->
1316 getNewRegNCG PtrRep `thenNat` \ tmp ->
1317 let code dst = toOL [
1318 SEGMENT DataSegment,
1320 DATA F [ImmFloat d],
1321 SEGMENT TextSegment,
1322 SETHI (HI (ImmCLbl lbl)) tmp,
1323 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1325 returnNat (Any FloatRep code)
1327 getRegister (StDouble d)
1328 = getNatLabelNCG `thenNat` \ lbl ->
1329 getNewRegNCG PtrRep `thenNat` \ tmp ->
1330 let code dst = toOL [
1331 SEGMENT DataSegment,
1333 DATA DF [ImmDouble d],
1334 SEGMENT TextSegment,
1335 SETHI (HI (ImmCLbl lbl)) tmp,
1336 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1338 returnNat (Any DoubleRep code)
1341 getRegister (StMachOp mop [x]) -- unary PrimOps
1343 MO_NatS_Neg -> trivialUCode (SUB False False g0) x
1344 MO_Nat_Not -> trivialUCode (XNOR False g0) x
1345 MO_32U_to_8U -> trivialCode (AND False) x (StInt 255)
1347 MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x
1348 MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x
1350 MO_Dbl_to_Flt -> coerceDbl2Flt x
1351 MO_Flt_to_Dbl -> coerceFlt2Dbl x
1353 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1354 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1355 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1356 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1358 -- Conversions which are a nop on sparc
1359 MO_32U_to_NatS -> conversionNop IntRep x
1360 MO_32S_to_NatS -> conversionNop IntRep x
1361 MO_NatS_to_32U -> conversionNop WordRep x
1362 MO_32U_to_NatU -> conversionNop WordRep x
1364 MO_NatU_to_NatS -> conversionNop IntRep x
1365 MO_NatS_to_NatU -> conversionNop WordRep x
1366 MO_NatP_to_NatU -> conversionNop WordRep x
1367 MO_NatU_to_NatP -> conversionNop PtrRep x
1368 MO_NatS_to_NatP -> conversionNop PtrRep x
1369 MO_NatP_to_NatS -> conversionNop IntRep x
1371 -- sign-extending widenings
1372 MO_8U_to_32U -> integerExtend False 24 x
1373 MO_8U_to_NatU -> integerExtend False 24 x
1374 MO_8S_to_NatS -> integerExtend True 24 x
1375 MO_16U_to_NatU -> integerExtend False 16 x
1376 MO_16S_to_NatS -> integerExtend True 16 x
1379 let fixed_x = if is_float_op -- promote to double
1380 then StMachOp MO_Flt_to_Dbl [x]
1383 getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1385 integerExtend signed nBits x
1387 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1388 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1390 conversionNop new_rep expr
1391 = getRegister expr `thenNat` \ e_code ->
1392 returnNat (swizzleRegisterRep e_code new_rep)
1396 MO_Flt_Exp -> (True, FSLIT("exp"))
1397 MO_Flt_Log -> (True, FSLIT("log"))
1398 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1400 MO_Flt_Sin -> (True, FSLIT("sin"))
1401 MO_Flt_Cos -> (True, FSLIT("cos"))
1402 MO_Flt_Tan -> (True, FSLIT("tan"))
1404 MO_Flt_Asin -> (True, FSLIT("asin"))
1405 MO_Flt_Acos -> (True, FSLIT("acos"))
1406 MO_Flt_Atan -> (True, FSLIT("atan"))
1408 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1409 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1410 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1412 MO_Dbl_Exp -> (False, FSLIT("exp"))
1413 MO_Dbl_Log -> (False, FSLIT("log"))
1414 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1416 MO_Dbl_Sin -> (False, FSLIT("sin"))
1417 MO_Dbl_Cos -> (False, FSLIT("cos"))
1418 MO_Dbl_Tan -> (False, FSLIT("tan"))
1420 MO_Dbl_Asin -> (False, FSLIT("asin"))
1421 MO_Dbl_Acos -> (False, FSLIT("acos"))
1422 MO_Dbl_Atan -> (False, FSLIT("atan"))
1424 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1425 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1426 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1428 other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1432 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1434 MO_32U_Gt -> condIntReg GTT x y
1435 MO_32U_Ge -> condIntReg GE x y
1436 MO_32U_Eq -> condIntReg EQQ x y
1437 MO_32U_Ne -> condIntReg NE x y
1438 MO_32U_Lt -> condIntReg LTT x y
1439 MO_32U_Le -> condIntReg LE x y
1441 MO_Nat_Eq -> condIntReg EQQ x y
1442 MO_Nat_Ne -> condIntReg NE x y
1444 MO_NatS_Gt -> condIntReg GTT x y
1445 MO_NatS_Ge -> condIntReg GE x y
1446 MO_NatS_Lt -> condIntReg LTT x y
1447 MO_NatS_Le -> condIntReg LE x y
1449 MO_NatU_Gt -> condIntReg GU x y
1450 MO_NatU_Ge -> condIntReg GEU x y
1451 MO_NatU_Lt -> condIntReg LU x y
1452 MO_NatU_Le -> condIntReg LEU x y
1454 MO_Flt_Gt -> condFltReg GTT x y
1455 MO_Flt_Ge -> condFltReg GE x y
1456 MO_Flt_Eq -> condFltReg EQQ x y
1457 MO_Flt_Ne -> condFltReg NE x y
1458 MO_Flt_Lt -> condFltReg LTT x y
1459 MO_Flt_Le -> condFltReg LE x y
1461 MO_Dbl_Gt -> condFltReg GTT x y
1462 MO_Dbl_Ge -> condFltReg GE x y
1463 MO_Dbl_Eq -> condFltReg EQQ x y
1464 MO_Dbl_Ne -> condFltReg NE x y
1465 MO_Dbl_Lt -> condFltReg LTT x y
1466 MO_Dbl_Le -> condFltReg LE x y
1468 MO_Nat_Add -> trivialCode (ADD False False) x y
1469 MO_Nat_Sub -> trivialCode (SUB False False) x y
1471 MO_NatS_Mul -> trivialCode (SMUL False) x y
1472 MO_NatU_Mul -> trivialCode (UMUL False) x y
1473 MO_NatS_MulMayOflo -> imulMayOflo x y
1475 -- ToDo: teach about V8+ SPARC div instructions
1476 MO_NatS_Quot -> idiv FSLIT(".div") x y
1477 MO_NatS_Rem -> idiv FSLIT(".rem") x y
1478 MO_NatU_Quot -> idiv FSLIT(".udiv") x y
1479 MO_NatU_Rem -> idiv FSLIT(".urem") x y
1481 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1482 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1483 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1484 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1486 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1487 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1488 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1489 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1491 MO_Nat_And -> trivialCode (AND False) x y
1492 MO_Nat_Or -> trivialCode (OR False) x y
1493 MO_Nat_Xor -> trivialCode (XOR False) x y
1495 MO_Nat_Shl -> trivialCode SLL x y
1496 MO_Nat_Shr -> trivialCode SRL x y
1497 MO_Nat_Sar -> trivialCode SRA x y
1499 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1500 [promote x, promote y])
1501 where promote x = StMachOp MO_Flt_to_Dbl [x]
1502 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1505 other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1507 idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1509 --------------------
1510 imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1512 = getNewRegNCG IntRep `thenNat` \ t1 ->
1513 getNewRegNCG IntRep `thenNat` \ t2 ->
1514 getNewRegNCG IntRep `thenNat` \ res_lo ->
1515 getNewRegNCG IntRep `thenNat` \ res_hi ->
1516 getRegister a1 `thenNat` \ reg1 ->
1517 getRegister a2 `thenNat` \ reg2 ->
1518 let code1 = registerCode reg1 t1
1519 code2 = registerCode reg2 t2
1520 src1 = registerName reg1 t1
1521 src2 = registerName reg2 t2
1522 code dst = code1 `appOL` code2 `appOL`
1524 SMUL False src1 (RIReg src2) res_lo,
1526 SRA res_lo (RIImm (ImmInt 31)) res_lo,
1527 SUB False False res_lo (RIReg res_hi) dst
1530 returnNat (Any IntRep code)
1532 getRegister (StInd pk mem)
1533 = getAmode mem `thenNat` \ amode ->
1535 code = amodeCode amode
1536 src = amodeAddr amode
1537 size = primRepToSize pk
1538 code__2 dst = code `snocOL` LD size src dst
1540 returnNat (Any pk code__2)
1542 getRegister (StInt i)
1545 src = ImmInt (fromInteger i)
1546 code dst = unitOL (OR False g0 (RIImm src) dst)
1548 returnNat (Any IntRep code)
1554 SETHI (HI imm__2) dst,
1555 OR False dst (RIImm (LO imm__2)) dst]
1557 returnNat (Any PtrRep code)
1559 = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1562 imm__2 = case imm of Just x -> x
1564 #endif /* sparc_TARGET_ARCH */
1566 #if powerpc_TARGET_ARCH
1567 getRegister (StMachOp mop [x]) -- unary MachOps
1569 MO_NatS_Neg -> trivialUCode NEG x
1570 MO_Nat_Not -> trivialUCode NOT x
1571 MO_32U_to_8U -> trivialCode AND x (StInt 255)
1573 MO_Flt_to_NatS -> coerceFP2Int FloatRep x
1574 MO_NatS_to_Flt -> coerceInt2FP FloatRep x
1575 MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
1576 MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
1578 -- Conversions which are a nop on PPC
1579 MO_NatS_to_32U -> conversionNop WordRep x
1580 MO_32U_to_NatS -> conversionNop IntRep x
1581 MO_32U_to_NatU -> conversionNop WordRep x
1583 MO_NatU_to_NatS -> conversionNop IntRep x
1584 MO_NatS_to_NatU -> conversionNop WordRep x
1585 MO_NatP_to_NatU -> conversionNop WordRep x
1586 MO_NatU_to_NatP -> conversionNop PtrRep x
1587 MO_NatS_to_NatP -> conversionNop PtrRep x
1588 MO_NatP_to_NatS -> conversionNop IntRep x
1590 MO_Dbl_to_Flt -> conversionNop FloatRep x
1591 MO_Flt_to_Dbl -> conversionNop DoubleRep x
1593 -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
1594 MO_8U_to_NatU -> integerExtend False 24 x
1595 MO_8S_to_NatS -> integerExtend True 24 x
1596 MO_16U_to_NatU -> integerExtend False 16 x
1597 MO_16S_to_NatS -> integerExtend True 16 x
1598 MO_8U_to_32U -> integerExtend False 24 x
1600 MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
1601 MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
1603 other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
1605 integerExtend signed nBits x
1607 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1608 [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1610 conversionNop new_rep expr
1611 = getRegister expr `thenNat` \ e_code ->
1612 returnNat (swizzleRegisterRep e_code new_rep)
1616 MO_Flt_Exp -> (True, FSLIT("exp"))
1617 MO_Flt_Log -> (True, FSLIT("log"))
1618 MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
1620 MO_Flt_Sin -> (True, FSLIT("sin"))
1621 MO_Flt_Cos -> (True, FSLIT("cos"))
1622 MO_Flt_Tan -> (True, FSLIT("tan"))
1624 MO_Flt_Asin -> (True, FSLIT("asin"))
1625 MO_Flt_Acos -> (True, FSLIT("acos"))
1626 MO_Flt_Atan -> (True, FSLIT("atan"))
1628 MO_Flt_Sinh -> (True, FSLIT("sinh"))
1629 MO_Flt_Cosh -> (True, FSLIT("cosh"))
1630 MO_Flt_Tanh -> (True, FSLIT("tanh"))
1632 MO_Dbl_Exp -> (False, FSLIT("exp"))
1633 MO_Dbl_Log -> (False, FSLIT("log"))
1634 MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
1636 MO_Dbl_Sin -> (False, FSLIT("sin"))
1637 MO_Dbl_Cos -> (False, FSLIT("cos"))
1638 MO_Dbl_Tan -> (False, FSLIT("tan"))
1640 MO_Dbl_Asin -> (False, FSLIT("asin"))
1641 MO_Dbl_Acos -> (False, FSLIT("acos"))
1642 MO_Dbl_Atan -> (False, FSLIT("atan"))
1644 MO_Dbl_Sinh -> (False, FSLIT("sinh"))
1645 MO_Dbl_Cosh -> (False, FSLIT("cosh"))
1646 MO_Dbl_Tanh -> (False, FSLIT("tanh"))
1648 other -> pprPanic "getRegister(powerpc) - unary StMachOp"
1652 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1654 MO_32U_Gt -> condIntReg GTT x y
1655 MO_32U_Ge -> condIntReg GE x y
1656 MO_32U_Eq -> condIntReg EQQ x y
1657 MO_32U_Ne -> condIntReg NE x y
1658 MO_32U_Lt -> condIntReg LTT x y
1659 MO_32U_Le -> condIntReg LE x y
1661 MO_Nat_Eq -> condIntReg EQQ x y
1662 MO_Nat_Ne -> condIntReg NE x y
1664 MO_NatS_Gt -> condIntReg GTT x y
1665 MO_NatS_Ge -> condIntReg GE x y
1666 MO_NatS_Lt -> condIntReg LTT x y
1667 MO_NatS_Le -> condIntReg LE x y
1669 MO_NatU_Gt -> condIntReg GU x y
1670 MO_NatU_Ge -> condIntReg GEU x y
1671 MO_NatU_Lt -> condIntReg LU x y
1672 MO_NatU_Le -> condIntReg LEU x y
1674 MO_Flt_Gt -> condFltReg GTT x y
1675 MO_Flt_Ge -> condFltReg GE x y
1676 MO_Flt_Eq -> condFltReg EQQ x y
1677 MO_Flt_Ne -> condFltReg NE x y
1678 MO_Flt_Lt -> condFltReg LTT x y
1679 MO_Flt_Le -> condFltReg LE x y
1681 MO_Dbl_Gt -> condFltReg GTT x y
1682 MO_Dbl_Ge -> condFltReg GE x y
1683 MO_Dbl_Eq -> condFltReg EQQ x y
1684 MO_Dbl_Ne -> condFltReg NE x y
1685 MO_Dbl_Lt -> condFltReg LTT x y
1686 MO_Dbl_Le -> condFltReg LE x y
1688 MO_Nat_Add -> trivialCode ADD x y
1689 MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
1690 case y of -- subfi ('substract from' with immediate) doesn't exist
1691 StInt imm -> if fits16Bits imm && imm /= (-32768)
1692 then Just $ trivialCode ADD x (StInt (-imm))
1696 MO_NatS_Mul -> trivialCode MULLW x y
1697 MO_NatU_Mul -> trivialCode MULLW x y
1698 -- MO_NatS_MulMayOflo ->
1700 MO_NatS_Quot -> trivialCode2 DIVW x y
1701 MO_NatU_Quot -> trivialCode2 DIVWU x y
1703 MO_NatS_Rem -> remainderCode DIVW x y
1704 MO_NatU_Rem -> remainderCode DIVWU x y
1706 MO_Nat_And -> trivialCode AND x y
1707 MO_Nat_Or -> trivialCode OR x y
1708 MO_Nat_Xor -> trivialCode XOR x y
1710 MO_Nat_Shl -> trivialCode SLW x y
1711 MO_Nat_Shr -> trivialCode SRW x y
1712 MO_Nat_Sar -> trivialCode SRAW x y
1714 MO_Flt_Add -> trivialFCode FloatRep FADD x y
1715 MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
1716 MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
1717 MO_Flt_Div -> trivialFCode FloatRep FDIV x y
1719 MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
1720 MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
1721 MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
1722 MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
1724 MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1726 MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1729 other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1731 getRegister (StInd pk mem)
1732 = getAmode mem `thenNat` \ amode ->
1734 code = amodeCode amode
1735 src = amodeAddr amode
1736 size = primRepToSize pk
1737 code__2 dst = code `snocOL` LD size dst src
1739 returnNat (Any pk code__2)
1741 getRegister (StInt i)
1744 src = ImmInt (fromInteger i)
1745 code dst = unitOL (LI dst src)
1747 returnNat (Any IntRep code)
1749 getRegister (StFloat d)
1750 = getNatLabelNCG `thenNat` \ lbl ->
1751 getNewRegNCG PtrRep `thenNat` \ tmp ->
1752 let code dst = toOL [
1753 SEGMENT RoDataSegment,
1755 DATA F [ImmFloat d],
1756 SEGMENT TextSegment,
1757 LIS tmp (HA (ImmCLbl lbl)),
1758 LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1760 returnNat (Any FloatRep code)
1762 getRegister (StDouble d)
1763 = getNatLabelNCG `thenNat` \ lbl ->
1764 getNewRegNCG PtrRep `thenNat` \ tmp ->
1765 let code dst = toOL [
1766 SEGMENT RoDataSegment,
1768 DATA DF [ImmDouble d],
1769 SEGMENT TextSegment,
1770 LIS tmp (HA (ImmCLbl lbl)),
1771 LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1773 returnNat (Any DoubleRep code)
1779 LIS dst (HI imm__2),
1780 OR dst dst (RIImm (LO imm__2))]
1782 returnNat (Any PtrRep code)
1784 = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1787 imm__2 = case imm of Just x -> x
1788 #endif /* powerpc_TARGET_ARCH */
1790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1792 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1796 %************************************************************************
1798 \subsection{The @Amode@ type}
1800 %************************************************************************
1802 @Amode@s: Memory addressing modes passed up the tree.
1804 data Amode = Amode MachRegsAddr InstrBlock
1806 amodeAddr (Amode addr _) = addr
1807 amodeCode (Amode _ code) = code
1810 Now, given a tree (the argument to an StInd) that references memory,
1811 produce a suitable addressing mode.
1813 A Rule of the Game (tm) for Amodes: use of the addr bit must
1814 immediately follow use of the code part, since the code part puts
1815 values in registers which the addr then refers to. So you can't put
1816 anything in between, lest it overwrite some of those registers. If
1817 you need to do some other computation between the code part and use of
1818 the addr bit, first store the effective address from the amode in a
1819 temporary, then do the other computation, and then use the temporary:
1823 ... other computation ...
1827 getAmode :: StixExpr -> NatM Amode
1829 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1831 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1833 #if alpha_TARGET_ARCH
1835 getAmode (StPrim IntSubOp [x, StInt i])
1836 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1837 getRegister x `thenNat` \ register ->
1839 code = registerCode register tmp
1840 reg = registerName register tmp
1841 off = ImmInt (-(fromInteger i))
1843 returnNat (Amode (AddrRegImm reg off) code)
1845 getAmode (StPrim IntAddOp [x, StInt i])
1846 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1847 getRegister x `thenNat` \ register ->
1849 code = registerCode register tmp
1850 reg = registerName register tmp
1851 off = ImmInt (fromInteger i)
1853 returnNat (Amode (AddrRegImm reg off) code)
1857 = returnNat (Amode (AddrImm imm__2) id)
1860 imm__2 = case imm of Just x -> x
1863 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1864 getRegister other `thenNat` \ register ->
1866 code = registerCode register tmp
1867 reg = registerName register tmp
1869 returnNat (Amode (AddrReg reg) code)
1871 #endif /* alpha_TARGET_ARCH */
1873 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1875 #if i386_TARGET_ARCH
1877 -- This is all just ridiculous, since it carefully undoes
1878 -- what mangleIndexTree has just done.
1879 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1880 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1881 getRegister x `thenNat` \ register ->
1883 code = registerCode register tmp
1884 reg = registerName register tmp
1885 off = ImmInt (-(fromInteger i))
1887 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1889 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1891 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1894 imm__2 = case imm of Just x -> x
1896 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1897 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1898 getRegister x `thenNat` \ register ->
1900 code = registerCode register tmp
1901 reg = registerName register tmp
1902 off = ImmInt (fromInteger i)
1904 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1906 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1907 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1908 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1909 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1910 getRegister x `thenNat` \ register1 ->
1911 getRegister y `thenNat` \ register2 ->
1913 code1 = registerCode register1 tmp1
1914 reg1 = registerName register1 tmp1
1915 code2 = registerCode register2 tmp2
1916 reg2 = registerName register2 tmp2
1917 code__2 = code1 `appOL` code2
1918 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1920 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1925 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1928 imm__2 = case imm of Just x -> x
1931 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1932 getRegister other `thenNat` \ register ->
1934 code = registerCode register tmp
1935 reg = registerName register tmp
1937 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1939 #endif /* i386_TARGET_ARCH */
1941 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1943 #if sparc_TARGET_ARCH
1945 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1947 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1948 getRegister x `thenNat` \ register ->
1950 code = registerCode register tmp
1951 reg = registerName register tmp
1952 off = ImmInt (-(fromInteger i))
1954 returnNat (Amode (AddrRegImm reg off) code)
1957 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1959 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1960 getRegister x `thenNat` \ register ->
1962 code = registerCode register tmp
1963 reg = registerName register tmp
1964 off = ImmInt (fromInteger i)
1966 returnNat (Amode (AddrRegImm reg off) code)
1968 getAmode (StMachOp MO_Nat_Add [x, y])
1969 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1970 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1971 getRegister x `thenNat` \ register1 ->
1972 getRegister y `thenNat` \ register2 ->
1974 code1 = registerCode register1 tmp1
1975 reg1 = registerName register1 tmp1
1976 code2 = registerCode register2 tmp2
1977 reg2 = registerName register2 tmp2
1978 code__2 = code1 `appOL` code2
1980 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1984 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1986 code = unitOL (SETHI (HI imm__2) tmp)
1988 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1991 imm__2 = case imm of Just x -> x
1994 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1995 getRegister other `thenNat` \ register ->
1997 code = registerCode register tmp
1998 reg = registerName register tmp
2001 returnNat (Amode (AddrRegImm reg off) code)
2003 #endif /* sparc_TARGET_ARCH */
2005 #ifdef powerpc_TARGET_ARCH
2006 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
2008 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2009 getRegister x `thenNat` \ register ->
2011 code = registerCode register tmp
2012 reg = registerName register tmp
2013 off = ImmInt (-(fromInteger i))
2015 returnNat (Amode (AddrRegImm reg off) code)
2018 getAmode (StMachOp MO_Nat_Add [x, StInt i])
2020 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2021 getRegister x `thenNat` \ register ->
2023 code = registerCode register tmp
2024 reg = registerName register tmp
2025 off = ImmInt (fromInteger i)
2027 returnNat (Amode (AddrRegImm reg off) code)
2031 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2033 code = unitOL (LIS tmp (HA imm__2))
2035 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
2038 imm__2 = case imm of Just x -> x
2041 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2042 getRegister other `thenNat` \ register ->
2044 code = registerCode register tmp
2045 reg = registerName register tmp
2048 returnNat (Amode (AddrRegImm reg off) code)
2049 #endif /* powerpc_TARGET_ARCH */
2051 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2054 %************************************************************************
2056 \subsection{The @CondCode@ type}
2058 %************************************************************************
2060 Condition codes passed up the tree.
2062 data CondCode = CondCode Bool Cond InstrBlock
2064 condName (CondCode _ cond _) = cond
2065 condFloat (CondCode is_float _ _) = is_float
2066 condCode (CondCode _ _ code) = code
2069 Set up a condition code for a conditional branch.
2072 getCondCode :: StixExpr -> NatM CondCode
2074 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2076 #if alpha_TARGET_ARCH
2077 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2078 #endif /* alpha_TARGET_ARCH */
2080 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2082 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2083 -- yes, they really do seem to want exactly the same!
2085 getCondCode (StMachOp mop [x, y])
2087 MO_32U_Gt -> condIntCode GTT x y
2088 MO_32U_Ge -> condIntCode GE x y
2089 MO_32U_Eq -> condIntCode EQQ x y
2090 MO_32U_Ne -> condIntCode NE x y
2091 MO_32U_Lt -> condIntCode LTT x y
2092 MO_32U_Le -> condIntCode LE x y
2094 MO_Nat_Eq -> condIntCode EQQ x y
2095 MO_Nat_Ne -> condIntCode NE x y
2097 MO_NatS_Gt -> condIntCode GTT x y
2098 MO_NatS_Ge -> condIntCode GE x y
2099 MO_NatS_Lt -> condIntCode LTT x y
2100 MO_NatS_Le -> condIntCode LE x y
2102 MO_NatU_Gt -> condIntCode GU x y
2103 MO_NatU_Ge -> condIntCode GEU x y
2104 MO_NatU_Lt -> condIntCode LU x y
2105 MO_NatU_Le -> condIntCode LEU x y
2107 MO_Flt_Gt -> condFltCode GTT x y
2108 MO_Flt_Ge -> condFltCode GE x y
2109 MO_Flt_Eq -> condFltCode EQQ x y
2110 MO_Flt_Ne -> condFltCode NE x y
2111 MO_Flt_Lt -> condFltCode LTT x y
2112 MO_Flt_Le -> condFltCode LE x y
2114 MO_Dbl_Gt -> condFltCode GTT x y
2115 MO_Dbl_Ge -> condFltCode GE x y
2116 MO_Dbl_Eq -> condFltCode EQQ x y
2117 MO_Dbl_Ne -> condFltCode NE x y
2118 MO_Dbl_Lt -> condFltCode LTT x y
2119 MO_Dbl_Le -> condFltCode LE x y
2121 other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2123 getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2125 #endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
2128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2133 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2134 passed back up the tree.
2137 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2139 #if alpha_TARGET_ARCH
2140 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2141 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2142 #endif /* alpha_TARGET_ARCH */
2144 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2145 #if i386_TARGET_ARCH
2147 -- memory vs immediate
2148 condIntCode cond (StInd pk x) y
2149 | Just i <- maybeImm y
2150 = getAmode x `thenNat` \ amode ->
2152 code1 = amodeCode amode
2153 x__2 = amodeAddr amode
2154 sz = primRepToSize pk
2155 code__2 = code1 `snocOL`
2156 CMP sz (OpImm i) (OpAddr x__2)
2158 returnNat (CondCode False cond code__2)
2161 condIntCode cond x (StInt 0)
2162 = getRegister x `thenNat` \ register1 ->
2163 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2165 code1 = registerCode register1 tmp1
2166 src1 = registerName register1 tmp1
2167 code__2 = code1 `snocOL`
2168 TEST L (OpReg src1) (OpReg src1)
2170 returnNat (CondCode False cond code__2)
2172 -- anything vs immediate
2173 condIntCode cond x y
2174 | Just i <- maybeImm y
2175 = getRegister x `thenNat` \ register1 ->
2176 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2178 code1 = registerCode register1 tmp1
2179 src1 = registerName register1 tmp1
2180 code__2 = code1 `snocOL`
2181 CMP L (OpImm i) (OpReg src1)
2183 returnNat (CondCode False cond code__2)
2185 -- memory vs anything
2186 condIntCode cond (StInd pk x) y
2187 = getAmode x `thenNat` \ amode_x ->
2188 getRegister y `thenNat` \ reg_y ->
2189 getNewRegNCG IntRep `thenNat` \ tmp ->
2191 c_x = amodeCode amode_x
2192 am_x = amodeAddr amode_x
2193 c_y = registerCode reg_y tmp
2194 r_y = registerName reg_y tmp
2195 sz = primRepToSize pk
2197 -- optimisation: if there's no code for x, just an amode,
2198 -- use whatever reg y winds up in. Assumes that c_y doesn't
2199 -- clobber any regs in the amode am_x, which I'm not sure is
2200 -- justified. The otherwise clause makes the same assumption.
2201 code__2 | isNilOL c_x
2203 CMP sz (OpReg r_y) (OpAddr am_x)
2207 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2209 CMP sz (OpReg tmp) (OpAddr am_x)
2211 returnNat (CondCode False cond code__2)
2213 -- anything vs memory
2215 condIntCode cond y (StInd pk x)
2216 = getAmode x `thenNat` \ amode_x ->
2217 getRegister y `thenNat` \ reg_y ->
2218 getNewRegNCG IntRep `thenNat` \ tmp ->
2220 c_x = amodeCode amode_x
2221 am_x = amodeAddr amode_x
2222 c_y = registerCode reg_y tmp
2223 r_y = registerName reg_y tmp
2224 sz = primRepToSize pk
2225 -- same optimisation and nagging doubts as previous clause
2226 code__2 | isNilOL c_x
2228 CMP sz (OpAddr am_x) (OpReg r_y)
2232 MOV L (OpReg r_y) (OpReg tmp) `appOL`
2234 CMP sz (OpAddr am_x) (OpReg tmp)
2236 returnNat (CondCode False cond code__2)
2238 -- anything vs anything
2239 condIntCode cond x y
2240 = getRegister x `thenNat` \ register1 ->
2241 getRegister y `thenNat` \ register2 ->
2242 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2243 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2245 code1 = registerCode register1 tmp1
2246 src1 = registerName register1 tmp1
2247 code2 = registerCode register2 tmp2
2248 src2 = registerName register2 tmp2
2249 code__2 = code1 `snocOL`
2250 MOV L (OpReg src1) (OpReg tmp1) `appOL`
2252 CMP L (OpReg src2) (OpReg tmp1)
2254 returnNat (CondCode False cond code__2)
2257 condFltCode cond x y
2258 = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2259 getRegister x `thenNat` \ register1 ->
2260 getRegister y `thenNat` \ register2 ->
2261 getNewRegNCG (registerRep register1)
2263 getNewRegNCG (registerRep register2)
2265 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2267 code1 = registerCode register1 tmp1
2268 src1 = registerName register1 tmp1
2270 code2 = registerCode register2 tmp2
2271 src2 = registerName register2 tmp2
2273 code__2 | isAny register1
2274 = code1 `appOL` -- result in tmp1
2280 GMOV src1 tmp1 `appOL`
2284 -- The GCMP insn does the test and sets the zero flag if comparable
2285 -- and true. Hence we always supply EQQ as the condition to test.
2286 returnNat (CondCode True EQQ code__2)
2288 #endif /* i386_TARGET_ARCH */
2290 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2292 #if sparc_TARGET_ARCH
2294 condIntCode cond x (StInt y)
2296 = getRegister x `thenNat` \ register ->
2297 getNewRegNCG IntRep `thenNat` \ tmp ->
2299 code = registerCode register tmp
2300 src1 = registerName register tmp
2301 src2 = ImmInt (fromInteger y)
2302 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2304 returnNat (CondCode False cond code__2)
2306 condIntCode cond x y
2307 = getRegister x `thenNat` \ register1 ->
2308 getRegister y `thenNat` \ register2 ->
2309 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2310 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2312 code1 = registerCode register1 tmp1
2313 src1 = registerName register1 tmp1
2314 code2 = registerCode register2 tmp2
2315 src2 = registerName register2 tmp2
2316 code__2 = code1 `appOL` code2 `snocOL`
2317 SUB False True src1 (RIReg src2) g0
2319 returnNat (CondCode False cond code__2)
2322 condFltCode cond x y
2323 = getRegister x `thenNat` \ register1 ->
2324 getRegister y `thenNat` \ register2 ->
2325 getNewRegNCG (registerRep register1)
2327 getNewRegNCG (registerRep register2)
2329 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2331 promote x = FxTOy F DF x tmp
2333 pk1 = registerRep register1
2334 code1 = registerCode register1 tmp1
2335 src1 = registerName register1 tmp1
2337 pk2 = registerRep register2
2338 code2 = registerCode register2 tmp2
2339 src2 = registerName register2 tmp2
2343 code1 `appOL` code2 `snocOL`
2344 FCMP True (primRepToSize pk1) src1 src2
2345 else if pk1 == FloatRep then
2346 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2347 FCMP True DF tmp src2
2349 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2350 FCMP True DF src1 tmp
2352 returnNat (CondCode True cond code__2)
2354 #endif /* sparc_TARGET_ARCH */
2356 #if powerpc_TARGET_ARCH
2358 condIntCode cond x (StInt y)
2360 = getRegister x `thenNat` \ register ->
2361 getNewRegNCG IntRep `thenNat` \ tmp ->
2363 code = registerCode register tmp
2364 src1 = registerName register tmp
2365 src2 = ImmInt (fromInteger y)
2366 code__2 = code `snocOL`
2367 (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2369 returnNat (CondCode False cond code__2)
2371 condIntCode cond x y
2372 = getRegister x `thenNat` \ register1 ->
2373 getRegister y `thenNat` \ register2 ->
2374 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2375 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2377 code1 = registerCode register1 tmp1
2378 src1 = registerName register1 tmp1
2379 code2 = registerCode register2 tmp2
2380 src2 = registerName register2 tmp2
2381 code__2 = code1 `appOL` code2 `snocOL`
2382 (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2384 returnNat (CondCode False cond code__2)
2386 condFltCode cond x y
2387 = getRegister x `thenNat` \ register1 ->
2388 getRegister y `thenNat` \ register2 ->
2389 getNewRegNCG (registerRep register1)
2391 getNewRegNCG (registerRep register2)
2394 code1 = registerCode register1 tmp1
2395 src1 = registerName register1 tmp1
2396 code2 = registerCode register2 tmp2
2397 src2 = registerName register2 tmp2
2398 code__2 = code1 `appOL` code2 `snocOL`
2401 returnNat (CondCode False cond code__2)
2403 #endif /* powerpc_TARGET_ARCH */
2406 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2409 %************************************************************************
2411 \subsection{Generating assignments}
2413 %************************************************************************
2415 Assignments are really at the heart of the whole code generation
2416 business. Almost all top-level nodes of any real importance are
2417 assignments, which correspond to loads, stores, or register transfers.
2418 If we're really lucky, some of the register transfers will go away,
2419 because we can use the destination register to complete the code
2420 generation for the right hand side. This only fails when the right
2421 hand side is forced into a fixed register (e.g. the result of a call).
2424 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2425 assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2427 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2428 assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock
2430 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2432 #if alpha_TARGET_ARCH
2434 assignIntCode pk (StInd _ dst) src
2435 = getNewRegNCG IntRep `thenNat` \ tmp ->
2436 getAmode dst `thenNat` \ amode ->
2437 getRegister src `thenNat` \ register ->
2439 code1 = amodeCode amode []
2440 dst__2 = amodeAddr amode
2441 code2 = registerCode register tmp []
2442 src__2 = registerName register tmp
2443 sz = primRepToSize pk
2444 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2448 assignIntCode pk dst src
2449 = getRegister dst `thenNat` \ register1 ->
2450 getRegister src `thenNat` \ register2 ->
2452 dst__2 = registerName register1 zeroh
2453 code = registerCode register2 dst__2
2454 src__2 = registerName register2 dst__2
2455 code__2 = if isFixed register2
2456 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2461 #endif /* alpha_TARGET_ARCH */
2463 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2465 #if i386_TARGET_ARCH
2467 -- non-FP assignment to memory
2468 assignMem_IntCode pk addr src
2469 = getAmode addr `thenNat` \ amode ->
2470 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
2471 getNewRegNCG PtrRep `thenNat` \ tmp ->
2473 -- In general, if the address computation for dst may require
2474 -- some insns preceding the addressing mode itself. So there's
2475 -- no guarantee that the code for dst and the code for src won't
2476 -- write the same register. This means either the address or
2477 -- the value needs to be copied into a temporary. We detect the
2478 -- common case where the amode has no code, and elide the copy.
2479 codea = amodeCode amode
2480 dst__a = amodeAddr amode
2482 code | isNilOL codea
2484 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2487 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2489 MOV (primRepToSize pk) opsrc
2490 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2496 -> NatM (InstrBlock,Operand) -- code, operator
2499 | Just x <- maybeImm op
2500 = returnNat (nilOL, OpImm x)
2503 = getRegister op `thenNat` \ register ->
2504 getNewRegNCG (registerRep register)
2506 let code = registerCode register tmp
2507 reg = registerName register tmp
2509 returnNat (code, OpReg reg)
2511 -- Assign; dst is a reg, rhs is mem
2512 assignReg_IntCode pk reg (StInd pks src)
2513 = getNewRegNCG PtrRep `thenNat` \ tmp ->
2514 getAmode src `thenNat` \ amode ->
2515 getRegisterReg reg `thenNat` \ reg_dst ->
2517 c_addr = amodeCode amode
2518 am_addr = amodeAddr amode
2519 r_dst = registerName reg_dst tmp
2520 szs = primRepToSize pks
2529 code = c_addr `snocOL`
2530 opc (OpAddr am_addr) (OpReg r_dst)
2534 -- dst is a reg, but src could be anything
2535 assignReg_IntCode pk reg src
2536 = getRegisterReg reg `thenNat` \ registerd ->
2537 getRegister src `thenNat` \ registers ->
2538 getNewRegNCG IntRep `thenNat` \ tmp ->
2540 r_dst = registerName registerd tmp
2541 r_src = registerName registers r_dst
2542 c_src = registerCode registers r_dst
2544 code = c_src `snocOL`
2545 MOV L (OpReg r_src) (OpReg r_dst)
2549 #endif /* i386_TARGET_ARCH */
2551 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2553 #if sparc_TARGET_ARCH
2555 assignMem_IntCode pk addr src
2556 = getNewRegNCG IntRep `thenNat` \ tmp ->
2557 getAmode addr `thenNat` \ amode ->
2558 getRegister src `thenNat` \ register ->
2560 code1 = amodeCode amode
2561 dst__2 = amodeAddr amode
2562 code2 = registerCode register tmp
2563 src__2 = registerName register tmp
2564 sz = primRepToSize pk
2565 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2569 assignReg_IntCode pk reg src
2570 = getRegister src `thenNat` \ register2 ->
2571 getRegisterReg reg `thenNat` \ register1 ->
2572 getNewRegNCG IntRep `thenNat` \ tmp ->
2574 dst__2 = registerName register1 tmp
2575 code = registerCode register2 dst__2
2576 src__2 = registerName register2 dst__2
2577 code__2 = if isFixed register2
2578 then code `snocOL` OR False g0 (RIReg src__2) dst__2
2583 #endif /* sparc_TARGET_ARCH */
2585 #if powerpc_TARGET_ARCH
2587 assignMem_IntCode pk addr src
2588 = getNewRegNCG IntRep `thenNat` \ tmp ->
2589 getAmode addr `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 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2601 assignReg_IntCode pk reg src
2602 = getRegister src `thenNat` \ register2 ->
2603 getRegisterReg reg `thenNat` \ register1 ->
2605 dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
2606 code = registerCode register2 dst__2
2607 src__2 = registerName register2 dst__2
2608 code__2 = if isFixed register2
2609 then code `snocOL` MR dst__2 src__2
2614 #endif /* powerpc_TARGET_ARCH */
2616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2619 % --------------------------------
2620 Floating-point assignments:
2621 % --------------------------------
2624 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2625 #if alpha_TARGET_ARCH
2627 assignFltCode pk (StInd _ dst) src
2628 = getNewRegNCG pk `thenNat` \ tmp ->
2629 getAmode dst `thenNat` \ amode ->
2630 getRegister src `thenNat` \ register ->
2632 code1 = amodeCode amode []
2633 dst__2 = amodeAddr amode
2634 code2 = registerCode register tmp []
2635 src__2 = registerName register tmp
2636 sz = primRepToSize pk
2637 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2641 assignFltCode pk dst src
2642 = getRegister dst `thenNat` \ register1 ->
2643 getRegister src `thenNat` \ register2 ->
2645 dst__2 = registerName register1 zeroh
2646 code = registerCode register2 dst__2
2647 src__2 = registerName register2 dst__2
2648 code__2 = if isFixed register2
2649 then code . mkSeqInstr (FMOV src__2 dst__2)
2654 #endif /* alpha_TARGET_ARCH */
2656 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2658 #if i386_TARGET_ARCH
2660 -- Floating point assignment to memory
2661 assignMem_FltCode pk addr src
2662 = getRegister src `thenNat` \ reg_src ->
2663 getRegister addr `thenNat` \ reg_addr ->
2664 getNewRegNCG pk `thenNat` \ tmp_src ->
2665 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
2666 let r_src = registerName reg_src tmp_src
2667 c_src = registerCode reg_src tmp_src
2668 r_addr = registerName reg_addr tmp_addr
2669 c_addr = registerCode reg_addr tmp_addr
2670 sz = primRepToSize pk
2672 code = c_src `appOL`
2673 -- no need to preserve r_src across the addr computation,
2674 -- since r_src must be a float reg
2675 -- whilst r_addr is an int reg
2678 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2682 -- Floating point assignment to a register/temporary
2683 assignReg_FltCode pk reg src
2684 = getRegisterReg reg `thenNat` \ reg_dst ->
2685 getRegister src `thenNat` \ reg_src ->
2686 getNewRegNCG pk `thenNat` \ tmp ->
2688 r_dst = registerName reg_dst tmp
2689 r_src = registerName reg_src r_dst
2690 c_src = registerCode reg_src r_dst
2692 code = if isFixed reg_src
2693 then c_src `snocOL` GMOV r_src r_dst
2699 #endif /* i386_TARGET_ARCH */
2701 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2703 #if sparc_TARGET_ARCH
2705 -- Floating point assignment to memory
2706 assignMem_FltCode pk addr src
2707 = getNewRegNCG pk `thenNat` \ tmp1 ->
2708 getAmode addr `thenNat` \ amode ->
2709 getRegister src `thenNat` \ register ->
2711 sz = primRepToSize pk
2712 dst__2 = amodeAddr amode
2714 code1 = amodeCode amode
2715 code2 = registerCode register tmp1
2717 src__2 = registerName register tmp1
2718 pk__2 = registerRep register
2719 sz__2 = primRepToSize pk__2
2721 code__2 = code1 `appOL` code2 `appOL`
2723 then unitOL (ST sz src__2 dst__2)
2724 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2728 -- Floating point assignment to a register/temporary
2729 -- Why is this so bizarrely ugly?
2730 assignReg_FltCode pk reg src
2731 = getRegisterReg reg `thenNat` \ register1 ->
2732 getRegister src `thenNat` \ register2 ->
2734 pk__2 = registerRep register2
2735 sz__2 = primRepToSize pk__2
2737 getNewRegNCG pk__2 `thenNat` \ tmp ->
2739 sz = primRepToSize pk
2740 dst__2 = registerName register1 g0 -- must be Fixed
2741 reg__2 = if pk /= pk__2 then tmp else dst__2
2742 code = registerCode register2 reg__2
2743 src__2 = registerName register2 reg__2
2746 code `snocOL` FxTOy sz__2 sz src__2 dst__2
2747 else if isFixed register2 then
2748 code `snocOL` FMOV sz src__2 dst__2
2754 #endif /* sparc_TARGET_ARCH */
2756 #if powerpc_TARGET_ARCH
2758 -- Floating point assignment to memory
2759 assignMem_FltCode pk addr src
2760 = getNewRegNCG pk `thenNat` \ tmp1 ->
2761 getAmode addr `thenNat` \ amode ->
2762 getRegister src `thenNat` \ register ->
2764 sz = primRepToSize pk
2765 dst__2 = amodeAddr amode
2767 code1 = amodeCode amode
2768 code2 = registerCode register tmp1
2770 src__2 = registerName register tmp1
2771 pk__2 = registerRep register
2773 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2777 -- Floating point assignment to a register/temporary
2778 assignReg_FltCode pk reg src
2779 = getRegisterReg reg `thenNat` \ reg_dst ->
2780 getRegister src `thenNat` \ reg_src ->
2781 getNewRegNCG pk `thenNat` \ tmp ->
2783 r_dst = registerName reg_dst tmp
2784 r_src = registerName reg_src r_dst
2785 c_src = registerCode reg_src r_dst
2787 code = if isFixed reg_src
2788 then c_src `snocOL` MR r_dst r_src
2792 #endif /* powerpc_TARGET_ARCH */
2794 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2797 %************************************************************************
2799 \subsection{Generating an unconditional branch}
2801 %************************************************************************
2803 We accept two types of targets: an immediate CLabel or a tree that
2804 gets evaluated into a register. Any CLabels which are AsmTemporaries
2805 are assumed to be in the local block of code, close enough for a
2806 branch instruction. Other CLabels are assumed to be far away.
2808 (If applicable) Do not fill the delay slots here; you will confuse the
2812 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2814 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2816 #if alpha_TARGET_ARCH
2818 genJump (StCLbl lbl)
2819 | isAsmTemp lbl = returnInstr (BR target)
2820 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2822 target = ImmCLbl lbl
2825 = getRegister tree `thenNat` \ register ->
2826 getNewRegNCG PtrRep `thenNat` \ tmp ->
2828 dst = registerName register pv
2829 code = registerCode register pv
2830 target = registerName register pv
2832 if isFixed register then
2833 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2835 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2837 #endif /* alpha_TARGET_ARCH */
2839 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2841 #if i386_TARGET_ARCH
2843 genJump dsts (StInd pk mem)
2844 = getAmode mem `thenNat` \ amode ->
2846 code = amodeCode amode
2847 target = amodeAddr amode
2849 returnNat (code `snocOL` JMP dsts (OpAddr target))
2853 = returnNat (unitOL (JMP dsts (OpImm target)))
2856 = getRegister tree `thenNat` \ register ->
2857 getNewRegNCG PtrRep `thenNat` \ tmp ->
2859 code = registerCode register tmp
2860 target = registerName register tmp
2862 returnNat (code `snocOL` JMP dsts (OpReg target))
2865 target = case imm of Just x -> x
2867 #endif /* i386_TARGET_ARCH */
2869 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2871 #if sparc_TARGET_ARCH
2873 genJump dsts (StCLbl lbl)
2874 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2875 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2876 | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP])
2878 target = ImmCLbl lbl
2881 = getRegister tree `thenNat` \ register ->
2882 getNewRegNCG PtrRep `thenNat` \ tmp ->
2884 code = registerCode register tmp
2885 target = registerName register tmp
2887 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2889 #endif /* sparc_TARGET_ARCH */
2891 #if powerpc_TARGET_ARCH
2892 genJump dsts (StCLbl lbl)
2893 | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
2894 | otherwise = returnNat (toOL [BCC ALWAYS lbl])
2897 = getRegister tree `thenNat` \ register ->
2898 getNewRegNCG PtrRep `thenNat` \ tmp ->
2900 code = registerCode register tmp
2901 target = registerName register tmp
2903 returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
2904 #endif /* sparc_TARGET_ARCH */
2906 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2911 %************************************************************************
2913 \subsection{Conditional jumps}
2915 %************************************************************************
2917 Conditional jumps are always to local labels, so we can use branch
2918 instructions. We peek at the arguments to decide what kind of
2921 ALPHA: For comparisons with 0, we're laughing, because we can just do
2922 the desired conditional branch.
2924 I386: First, we have to ensure that the condition
2925 codes are set according to the supplied comparison operation.
2927 SPARC: First, we have to ensure that the condition codes are set
2928 according to the supplied comparison operation. We generate slightly
2929 different code for floating point comparisons, because a floating
2930 point operation cannot directly precede a @BF@. We assume the worst
2931 and fill that slot with a @NOP@.
2933 SPARC: Do not fill the delay slots here; you will confuse the register
2938 :: CLabel -- the branch target
2939 -> StixExpr -- the condition on which to branch
2942 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2944 #if alpha_TARGET_ARCH
2946 genCondJump lbl (StPrim op [x, StInt 0])
2947 = getRegister x `thenNat` \ register ->
2948 getNewRegNCG (registerRep register)
2951 code = registerCode register tmp
2952 value = registerName register tmp
2953 pk = registerRep register
2954 target = ImmCLbl lbl
2956 returnSeq code [BI (cmpOp op) value target]
2958 cmpOp CharGtOp = GTT
2960 cmpOp CharEqOp = EQQ
2962 cmpOp CharLtOp = LTT
2971 cmpOp WordGeOp = ALWAYS
2972 cmpOp WordEqOp = EQQ
2974 cmpOp WordLtOp = NEVER
2975 cmpOp WordLeOp = EQQ
2977 cmpOp AddrGeOp = ALWAYS
2978 cmpOp AddrEqOp = EQQ
2980 cmpOp AddrLtOp = NEVER
2981 cmpOp AddrLeOp = EQQ
2983 genCondJump lbl (StPrim op [x, StDouble 0.0])
2984 = getRegister x `thenNat` \ register ->
2985 getNewRegNCG (registerRep register)
2988 code = registerCode register tmp
2989 value = registerName register tmp
2990 pk = registerRep register
2991 target = ImmCLbl lbl
2993 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2995 cmpOp FloatGtOp = GTT
2996 cmpOp FloatGeOp = GE
2997 cmpOp FloatEqOp = EQQ
2998 cmpOp FloatNeOp = NE
2999 cmpOp FloatLtOp = LTT
3000 cmpOp FloatLeOp = LE
3001 cmpOp DoubleGtOp = GTT
3002 cmpOp DoubleGeOp = GE
3003 cmpOp DoubleEqOp = EQQ
3004 cmpOp DoubleNeOp = NE
3005 cmpOp DoubleLtOp = LTT
3006 cmpOp DoubleLeOp = LE
3008 genCondJump lbl (StPrim op [x, y])
3010 = trivialFCode pr instr x y `thenNat` \ register ->
3011 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3013 code = registerCode register tmp
3014 result = registerName register tmp
3015 target = ImmCLbl lbl
3017 returnNat (code . mkSeqInstr (BF cond result target))
3019 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
3021 fltCmpOp op = case op of
3035 (instr, cond) = case op of
3036 FloatGtOp -> (FCMP TF LE, EQQ)
3037 FloatGeOp -> (FCMP TF LTT, EQQ)
3038 FloatEqOp -> (FCMP TF EQQ, NE)
3039 FloatNeOp -> (FCMP TF EQQ, EQQ)
3040 FloatLtOp -> (FCMP TF LTT, NE)
3041 FloatLeOp -> (FCMP TF LE, NE)
3042 DoubleGtOp -> (FCMP TF LE, EQQ)
3043 DoubleGeOp -> (FCMP TF LTT, EQQ)
3044 DoubleEqOp -> (FCMP TF EQQ, NE)
3045 DoubleNeOp -> (FCMP TF EQQ, EQQ)
3046 DoubleLtOp -> (FCMP TF LTT, NE)
3047 DoubleLeOp -> (FCMP TF LE, NE)
3049 genCondJump lbl (StPrim op [x, y])
3050 = trivialCode instr x y `thenNat` \ register ->
3051 getNewRegNCG IntRep `thenNat` \ tmp ->
3053 code = registerCode register tmp
3054 result = registerName register tmp
3055 target = ImmCLbl lbl
3057 returnNat (code . mkSeqInstr (BI cond result target))
3059 (instr, cond) = case op of
3060 CharGtOp -> (CMP LE, EQQ)
3061 CharGeOp -> (CMP LTT, EQQ)
3062 CharEqOp -> (CMP EQQ, NE)
3063 CharNeOp -> (CMP EQQ, EQQ)
3064 CharLtOp -> (CMP LTT, NE)
3065 CharLeOp -> (CMP LE, NE)
3066 IntGtOp -> (CMP LE, EQQ)
3067 IntGeOp -> (CMP LTT, EQQ)
3068 IntEqOp -> (CMP EQQ, NE)
3069 IntNeOp -> (CMP EQQ, EQQ)
3070 IntLtOp -> (CMP LTT, NE)
3071 IntLeOp -> (CMP LE, NE)
3072 WordGtOp -> (CMP ULE, EQQ)
3073 WordGeOp -> (CMP ULT, EQQ)
3074 WordEqOp -> (CMP EQQ, NE)
3075 WordNeOp -> (CMP EQQ, EQQ)
3076 WordLtOp -> (CMP ULT, NE)
3077 WordLeOp -> (CMP ULE, NE)
3078 AddrGtOp -> (CMP ULE, EQQ)
3079 AddrGeOp -> (CMP ULT, EQQ)
3080 AddrEqOp -> (CMP EQQ, NE)
3081 AddrNeOp -> (CMP EQQ, EQQ)
3082 AddrLtOp -> (CMP ULT, NE)
3083 AddrLeOp -> (CMP ULE, NE)
3085 #endif /* alpha_TARGET_ARCH */
3087 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3089 #if i386_TARGET_ARCH
3091 genCondJump lbl bool
3092 = getCondCode bool `thenNat` \ condition ->
3094 code = condCode condition
3095 cond = condName condition
3097 returnNat (code `snocOL` JXX cond lbl)
3099 #endif /* i386_TARGET_ARCH */
3101 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3103 #if sparc_TARGET_ARCH
3105 genCondJump lbl bool
3106 = getCondCode bool `thenNat` \ condition ->
3108 code = condCode condition
3109 cond = condName condition
3110 target = ImmCLbl lbl
3115 if condFloat condition
3116 then [NOP, BF cond False target, NOP]
3117 else [BI cond False target, NOP]
3121 #endif /* sparc_TARGET_ARCH */
3123 #if powerpc_TARGET_ARCH
3125 genCondJump lbl bool
3126 = getCondCode bool `thenNat` \ condition ->
3128 code = condCode condition
3129 cond = condName condition
3130 target = ImmCLbl lbl
3133 code `snocOL` BCC cond lbl )
3135 #endif /* powerpc_TARGET_ARCH */
3137 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3139 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3142 %************************************************************************
3144 \subsection{Generating C calls}
3146 %************************************************************************
3148 Now the biggest nightmare---calls. Most of the nastiness is buried in
3149 @get_arg@, which moves the arguments to the correct registers/stack
3150 locations. Apart from that, the code is easy.
3152 (If applicable) Do not fill the delay slots here; you will confuse the
3157 :: (Either FastString StixExpr) -- function to call
3159 -> PrimRep -- type of the result
3160 -> [StixExpr] -- arguments (of mixed type)
3163 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3165 #if alpha_TARGET_ARCH
3167 genCCall fn cconv kind args
3168 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3169 `thenNat` \ ((unused,_), argCode) ->
3171 nRegs = length allArgRegs - length unused
3172 code = asmSeqThen (map ($ []) argCode)
3175 LDA pv (AddrImm (ImmLab (ptext fn))),
3176 JSR ra (AddrReg pv) nRegs,
3177 LDGP gp (AddrReg ra)]
3179 ------------------------
3180 {- Try to get a value into a specific register (or registers) for
3181 a call. The first 6 arguments go into the appropriate
3182 argument register (separate registers for integer and floating
3183 point arguments, but used in lock-step), and the remaining
3184 arguments are dumped to the stack, beginning at 0(sp). Our
3185 first argument is a pair of the list of remaining argument
3186 registers to be assigned for this call and the next stack
3187 offset to use for overflowing arguments. This way,
3188 @get_Arg@ can be applied to all of a call's arguments using
3192 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
3193 -> StixTree -- Current argument
3194 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3196 -- We have to use up all of our argument registers first...
3198 get_arg ((iDst,fDst):dsts, offset) arg
3199 = getRegister arg `thenNat` \ register ->
3201 reg = if isFloatingRep pk then fDst else iDst
3202 code = registerCode register reg
3203 src = registerName register reg
3204 pk = registerRep register
3207 if isFloatingRep pk then
3208 ((dsts, offset), if isFixed register then
3209 code . mkSeqInstr (FMOV src fDst)
3212 ((dsts, offset), if isFixed register then
3213 code . mkSeqInstr (OR src (RIReg src) iDst)
3216 -- Once we have run out of argument registers, we move to the
3219 get_arg ([], offset) arg
3220 = getRegister arg `thenNat` \ register ->
3221 getNewRegNCG (registerRep register)
3224 code = registerCode register tmp
3225 src = registerName register tmp
3226 pk = registerRep register
3227 sz = primRepToSize pk
3229 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3231 #endif /* alpha_TARGET_ARCH */
3233 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3235 #if i386_TARGET_ARCH
3237 genCCall fn cconv ret_rep args
3239 (reverse args) `thenNat` \ sizes_n_codes ->
3240 getDeltaNat `thenNat` \ delta ->
3241 let (sizes, push_codes) = unzip sizes_n_codes
3242 tot_arg_size = sum sizes
3244 -- deal with static vs dynamic call targets
3247 -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3249 -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3250 ASSERT(case dyn_rep of { L -> True; _ -> False})
3251 returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3253 `thenNat` \ callinsns ->
3254 let push_code = concatOL push_codes
3255 call = callinsns `appOL`
3257 -- Deallocate parameters after call for ccall;
3258 -- but not for stdcall (callee does it)
3259 (if cconv == StdCallConv then [] else
3260 [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3262 [DELTA (delta + tot_arg_size)]
3265 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3266 returnNat (push_code `appOL` call)
3269 -- function names that begin with '.' are assumed to be special
3270 -- internally generated names like '.mul,' which don't get an
3271 -- underscore prefix
3272 -- ToDo:needed (WDP 96/03) ???
3273 fn_u = unpackFS (unLeft fn)
3276 = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3277 | otherwise -- General case
3278 = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3280 stdcallsize tot_arg_size
3281 | cconv == StdCallConv = '@':show tot_arg_size
3289 push_arg :: StixExpr{-current argument-}
3290 -> NatM (Int, InstrBlock) -- argsz, code
3293 | is64BitRep arg_rep
3294 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3295 getDeltaNat `thenNat` \ delta ->
3296 setDeltaNat (delta - 8) `thenNat` \ _ ->
3297 let r_lo = VirtualRegI vr_lo
3298 r_hi = getHiVRegFromLo r_lo
3301 toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3302 PUSH L (OpReg r_lo), DELTA (delta - 8)]
3305 = get_op arg `thenNat` \ (code, reg, sz) ->
3306 getDeltaNat `thenNat` \ delta ->
3307 arg_size sz `bind` \ size ->
3308 setDeltaNat (delta-size) `thenNat` \ _ ->
3309 if (case sz of DF -> True; F -> True; _ -> False)
3310 then returnNat (size,
3312 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3314 GST sz reg (AddrBaseIndex (Just esp)
3318 else returnNat (size,
3320 PUSH L (OpReg reg) `snocOL`
3324 arg_rep = repOfStixExpr arg
3329 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3332 = getRegister op `thenNat` \ register ->
3333 getNewRegNCG (registerRep register)
3336 code = registerCode register tmp
3337 reg = registerName register tmp
3338 pk = registerRep register
3339 sz = primRepToSize pk
3341 returnNat (code, reg, sz)
3343 #endif /* i386_TARGET_ARCH */
3345 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3347 #if sparc_TARGET_ARCH
3349 The SPARC calling convention is an absolute
3350 nightmare. The first 6x32 bits of arguments are mapped into
3351 %o0 through %o5, and the remaining arguments are dumped to the
3352 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
3354 If we have to put args on the stack, move %o6==%sp down by
3355 the number of words to go on the stack, to ensure there's enough space.
3357 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3358 16 words above the stack pointer is a word for the address of
3359 a structure return value. I use this as a temporary location
3360 for moving values from float to int regs. Certainly it isn't
3361 safe to put anything in the 16 words starting at %sp, since
3362 this area can get trashed at any time due to window overflows
3363 caused by signal handlers.
3365 A final complication (if the above isn't enough) is that
3366 we can't blithely calculate the arguments one by one into
3367 %o0 .. %o5. Consider the following nested calls:
3371 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
3372 the inner call will itself use %o0, which trashes the value put there
3373 in preparation for the outer call. Upshot: we need to calculate the
3374 args into temporary regs, and move those to arg regs or onto the
3375 stack only immediately prior to the call proper. Sigh.
3378 genCCall fn cconv kind args
3379 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3381 (argcodes, vregss) = unzip argcode_and_vregs
3382 n_argRegs = length allArgRegs
3383 n_argRegs_used = min (length vregs) n_argRegs
3384 vregs = concat vregss
3386 -- deal with static vs dynamic call targets
3389 -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3391 -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3392 returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3394 `thenNat` \ callinsns ->
3396 argcode = concatOL argcodes
3397 (move_sp_down, move_sp_up)
3398 = let diff = length vregs - n_argRegs
3399 nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3402 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3404 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3406 returnNat (argcode `appOL`
3407 move_sp_down `appOL`
3408 transfer_code `appOL`
3413 -- function names that begin with '.' are assumed to be special
3414 -- internally generated names like '.mul,' which don't get an
3415 -- underscore prefix
3416 -- ToDo:needed (WDP 96/03) ???
3417 fn_static = unLeft fn
3418 fn__2 = case (headFS fn_static) of
3419 '.' -> ImmLit (ftext fn_static)
3420 _ -> ImmLab False (ftext fn_static)
3422 -- move args from the integer vregs into which they have been
3423 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3424 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3426 move_final [] _ offset -- all args done
3429 move_final (v:vs) [] offset -- out of aregs; move to stack
3430 = ST W v (spRel offset)
3431 : move_final vs [] (offset+1)
3433 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3434 = OR False g0 (RIReg v) a
3435 : move_final vs az offset
3437 -- generate code to calculate an argument, and move it into one
3438 -- or two integer vregs.
3439 arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3440 arg_to_int_vregs arg
3441 | is64BitRep (repOfStixExpr arg)
3442 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3443 let r_lo = VirtualRegI vr_lo
3444 r_hi = getHiVRegFromLo r_lo
3445 in returnNat (code, [r_hi, r_lo])
3447 = getRegister arg `thenNat` \ register ->
3448 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3449 let code = registerCode register tmp
3450 src = registerName register tmp
3451 pk = registerRep register
3453 -- the value is in src. Get it into 1 or 2 int vregs.
3456 getNewRegNCG WordRep `thenNat` \ v1 ->
3457 getNewRegNCG WordRep `thenNat` \ v2 ->
3460 FMOV DF src f0 `snocOL`
3461 ST F f0 (spRel 16) `snocOL`
3462 LD W (spRel 16) v1 `snocOL`
3463 ST F (fPair f0) (spRel 16) `snocOL`
3469 getNewRegNCG WordRep `thenNat` \ v1 ->
3472 ST F src (spRel 16) `snocOL`
3478 getNewRegNCG WordRep `thenNat` \ v1 ->
3480 code `snocOL` OR False g0 (RIReg src) v1
3484 #endif /* sparc_TARGET_ARCH */
3486 #if powerpc_TARGET_ARCH
3488 The PowerPC calling convention (at least for Darwin/Mac OS X)
3489 is described in Apple's document
3490 "Inside Mac OS X - Mach-O Runtime Architecture".
3491 Parameters may be passed in general-purpose registers, in
3492 floating point registers, or on the stack. Stack space is
3493 always reserved for parameters, even if they are passed in registers.
3494 The called routine may choose to save parameters from registers
3495 to the corresponding space on the stack.
3496 The parameter area should be part of the caller's stack frame,
3497 allocated in the caller's prologue code (large enough to hold
3498 the parameter lists for all called routines). The NCG already
3499 uses the space that we should use as a parameter area for register
3500 spilling, so we allocate a new stack frame just before ccalling.
3501 That way we don't need to decide beforehand how much space to
3502 reserve for parameters.
3505 genCCall fn cconv kind args
3506 = mapNat prepArg args `thenNat` \ preppedArgs ->
3508 (argReps,argCodes,vregs) = unzip3 preppedArgs
3510 -- size of linkage area + size of arguments, in bytes
3511 stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3512 roundTo16 x | x `mod` 16 == 0 = x
3513 | otherwise = x + 16 - (x `mod` 16)
3515 move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3516 move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3518 (moveFinalCode,usedRegs) = move_final
3520 allArgRegs allFPArgRegs
3524 passArguments = concatOL argCodes
3525 `appOL` move_sp_down
3526 `appOL` moveFinalCode
3530 addImportNat lbl `thenNat` \ _ ->
3531 returnNat (passArguments
3532 `snocOL` BL (ImmLit $ ftext
3535 `appendFS` FSLIT("$stub")))
3539 getRegister dyn `thenNat` \ dynReg ->
3540 getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
3541 returnNat (registerCode dynReg tmp
3542 `appOL` passArguments
3543 `snocOL` MTCTR (registerName dynReg tmp)
3544 `snocOL` BCTRL usedRegs
3548 | is64BitRep (repOfStixExpr arg)
3549 = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
3550 let r_lo = VirtualRegI vr_lo
3551 r_hi = getHiVRegFromLo r_lo
3552 in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3554 = getRegister arg `thenNat` \ register ->
3555 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3556 returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3557 move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3558 move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3559 | not (is64BitRep rep) =
3562 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3565 fpr : fprs -> MR fpr vr
3566 [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3567 ((take 1 fprs) ++ accumUsed)
3569 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3572 fpr : fprs -> MR fpr vr
3573 [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3574 ((take 1 fprs) ++ accumUsed)
3575 VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3577 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3580 gpr : gprs -> MR gpr vr
3581 [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3582 ((take 1 gprs) ++ accumUsed)
3584 move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3587 storeWord vr (gpr:_) offset = MR gpr vr
3588 storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3590 move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3592 `snocOL` storeWord vr_hi gprs stackOffset
3593 `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3594 ((take 2 gprs) ++ accumUsed)
3595 #endif /* powerpc_TARGET_ARCH */
3597 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3600 %************************************************************************
3602 \subsection{Support bits}
3604 %************************************************************************
3606 %************************************************************************
3608 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3610 %************************************************************************
3612 Turn those condition codes into integers now (when they appear on
3613 the right hand side of an assignment).
3615 (If applicable) Do not fill the delay slots here; you will confuse the
3619 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3621 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3623 #if alpha_TARGET_ARCH
3624 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3625 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3626 #endif /* alpha_TARGET_ARCH */
3628 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3630 #if i386_TARGET_ARCH
3633 = condIntCode cond x y `thenNat` \ condition ->
3634 getNewRegNCG IntRep `thenNat` \ tmp ->
3636 code = condCode condition
3637 cond = condName condition
3638 code__2 dst = code `appOL` toOL [
3639 SETCC cond (OpReg tmp),
3640 AND L (OpImm (ImmInt 1)) (OpReg tmp),
3641 MOV L (OpReg tmp) (OpReg dst)]
3643 returnNat (Any IntRep code__2)
3646 = getNatLabelNCG `thenNat` \ lbl1 ->
3647 getNatLabelNCG `thenNat` \ lbl2 ->
3648 condFltCode cond x y `thenNat` \ condition ->
3650 code = condCode condition
3651 cond = condName condition
3652 code__2 dst = code `appOL` toOL [
3654 MOV L (OpImm (ImmInt 0)) (OpReg dst),
3657 MOV L (OpImm (ImmInt 1)) (OpReg dst),
3660 returnNat (Any IntRep code__2)
3662 #endif /* i386_TARGET_ARCH */
3664 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3666 #if sparc_TARGET_ARCH
3668 condIntReg EQQ x (StInt 0)
3669 = getRegister x `thenNat` \ register ->
3670 getNewRegNCG IntRep `thenNat` \ tmp ->
3672 code = registerCode register tmp
3673 src = registerName register tmp
3674 code__2 dst = code `appOL` toOL [
3675 SUB False True g0 (RIReg src) g0,
3676 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3678 returnNat (Any IntRep code__2)
3681 = getRegister x `thenNat` \ register1 ->
3682 getRegister y `thenNat` \ register2 ->
3683 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3684 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3686 code1 = registerCode register1 tmp1
3687 src1 = registerName register1 tmp1
3688 code2 = registerCode register2 tmp2
3689 src2 = registerName register2 tmp2
3690 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3691 XOR False src1 (RIReg src2) dst,
3692 SUB False True g0 (RIReg dst) g0,
3693 SUB True False g0 (RIImm (ImmInt (-1))) dst]
3695 returnNat (Any IntRep code__2)
3697 condIntReg NE x (StInt 0)
3698 = getRegister x `thenNat` \ register ->
3699 getNewRegNCG IntRep `thenNat` \ tmp ->
3701 code = registerCode register tmp
3702 src = registerName register tmp
3703 code__2 dst = code `appOL` toOL [
3704 SUB False True g0 (RIReg src) g0,
3705 ADD True False g0 (RIImm (ImmInt 0)) dst]
3707 returnNat (Any IntRep code__2)
3710 = getRegister x `thenNat` \ register1 ->
3711 getRegister y `thenNat` \ register2 ->
3712 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3713 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3715 code1 = registerCode register1 tmp1
3716 src1 = registerName register1 tmp1
3717 code2 = registerCode register2 tmp2
3718 src2 = registerName register2 tmp2
3719 code__2 dst = code1 `appOL` code2 `appOL` toOL [
3720 XOR False src1 (RIReg src2) dst,
3721 SUB False True g0 (RIReg dst) g0,
3722 ADD True False g0 (RIImm (ImmInt 0)) dst]
3724 returnNat (Any IntRep code__2)
3727 = getNatLabelNCG `thenNat` \ lbl1 ->
3728 getNatLabelNCG `thenNat` \ lbl2 ->
3729 condIntCode cond x y `thenNat` \ condition ->
3731 code = condCode condition
3732 cond = condName condition
3733 code__2 dst = code `appOL` toOL [
3734 BI cond False (ImmCLbl lbl1), NOP,
3735 OR False g0 (RIImm (ImmInt 0)) dst,
3736 BI ALWAYS False (ImmCLbl lbl2), NOP,
3738 OR False g0 (RIImm (ImmInt 1)) dst,
3741 returnNat (Any IntRep code__2)
3744 = getNatLabelNCG `thenNat` \ lbl1 ->
3745 getNatLabelNCG `thenNat` \ lbl2 ->
3746 condFltCode cond x y `thenNat` \ condition ->
3748 code = condCode condition
3749 cond = condName condition
3750 code__2 dst = code `appOL` toOL [
3752 BF cond False (ImmCLbl lbl1), NOP,
3753 OR False g0 (RIImm (ImmInt 0)) dst,
3754 BI ALWAYS False (ImmCLbl lbl2), NOP,
3756 OR False g0 (RIImm (ImmInt 1)) dst,
3759 returnNat (Any IntRep code__2)
3761 #endif /* sparc_TARGET_ARCH */
3763 #if powerpc_TARGET_ARCH
3765 = getNatLabelNCG `thenNat` \ lbl ->
3766 condIntCode cond x y `thenNat` \ condition ->
3768 code = condCode condition
3769 cond = condName condition
3770 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3775 returnNat (Any IntRep code__2)
3778 = getNatLabelNCG `thenNat` \ lbl ->
3779 condFltCode cond x y `thenNat` \ condition ->
3781 code = condCode condition
3782 cond = condName condition
3783 code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3788 returnNat (Any IntRep code__2)
3789 #endif /* powerpc_TARGET_ARCH */
3791 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3794 %************************************************************************
3796 \subsubsection{@trivial*Code@: deal with trivial instructions}
3798 %************************************************************************
3800 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3801 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
3802 for constants on the right hand side, because that's where the generic
3803 optimizer will have put them.
3805 Similarly, for unary instructions, we don't have to worry about
3806 matching an StInt as the argument, because genericOpt will already
3807 have handled the constant-folding.
3811 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3812 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3813 -> Maybe (Operand -> Operand -> Instr)
3814 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3815 ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3817 -> StixExpr -> StixExpr -- the two arguments
3822 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3823 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3824 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3825 ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3827 -> StixExpr -> StixExpr -- the two arguments
3831 :: IF_ARCH_alpha((RI -> Reg -> Instr)
3832 ,IF_ARCH_i386 ((Operand -> Instr)
3833 ,IF_ARCH_sparc((RI -> Reg -> Instr)
3834 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3836 -> StixExpr -- the one argument
3841 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3842 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3843 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3844 ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3846 -> StixExpr -- the one argument
3849 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3851 #if alpha_TARGET_ARCH
3853 trivialCode instr x (StInt y)
3855 = getRegister x `thenNat` \ register ->
3856 getNewRegNCG IntRep `thenNat` \ tmp ->
3858 code = registerCode register tmp
3859 src1 = registerName register tmp
3860 src2 = ImmInt (fromInteger y)
3861 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3863 returnNat (Any IntRep code__2)
3865 trivialCode instr x y
3866 = getRegister x `thenNat` \ register1 ->
3867 getRegister y `thenNat` \ register2 ->
3868 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3869 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3871 code1 = registerCode register1 tmp1 []
3872 src1 = registerName register1 tmp1
3873 code2 = registerCode register2 tmp2 []
3874 src2 = registerName register2 tmp2
3875 code__2 dst = asmSeqThen [code1, code2] .
3876 mkSeqInstr (instr src1 (RIReg src2) dst)
3878 returnNat (Any IntRep code__2)
3881 trivialUCode instr x
3882 = getRegister x `thenNat` \ register ->
3883 getNewRegNCG IntRep `thenNat` \ tmp ->
3885 code = registerCode register tmp
3886 src = registerName register tmp
3887 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3889 returnNat (Any IntRep code__2)
3892 trivialFCode _ instr x y
3893 = getRegister x `thenNat` \ register1 ->
3894 getRegister y `thenNat` \ register2 ->
3895 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
3896 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
3898 code1 = registerCode register1 tmp1
3899 src1 = registerName register1 tmp1
3901 code2 = registerCode register2 tmp2
3902 src2 = registerName register2 tmp2
3904 code__2 dst = asmSeqThen [code1 [], code2 []] .
3905 mkSeqInstr (instr src1 src2 dst)
3907 returnNat (Any DoubleRep code__2)
3909 trivialUFCode _ instr x
3910 = getRegister x `thenNat` \ register ->
3911 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3913 code = registerCode register tmp
3914 src = registerName register tmp
3915 code__2 dst = code . mkSeqInstr (instr src dst)
3917 returnNat (Any DoubleRep code__2)
3919 #endif /* alpha_TARGET_ARCH */
3921 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3923 #if i386_TARGET_ARCH
3925 The Rules of the Game are:
3927 * You cannot assume anything about the destination register dst;
3928 it may be anything, including a fixed reg.
3930 * You may compute an operand into a fixed reg, but you may not
3931 subsequently change the contents of that fixed reg. If you
3932 want to do so, first copy the value either to a temporary
3933 or into dst. You are free to modify dst even if it happens
3934 to be a fixed reg -- that's not your problem.
3936 * You cannot assume that a fixed reg will stay live over an
3937 arbitrary computation. The same applies to the dst reg.
3939 * Temporary regs obtained from getNewRegNCG are distinct from
3940 each other and from all other regs, and stay live over
3941 arbitrary computations.
3945 trivialCode instr maybe_revinstr a b
3948 = getRegister a `thenNat` \ rega ->
3951 then registerCode rega dst `bind` \ code_a ->
3953 instr (OpImm imm_b) (OpReg dst)
3954 else registerCodeF rega `bind` \ code_a ->
3955 registerNameF rega `bind` \ r_a ->
3957 MOV L (OpReg r_a) (OpReg dst) `snocOL`
3958 instr (OpImm imm_b) (OpReg dst)
3960 returnNat (Any IntRep mkcode)
3963 = getRegister b `thenNat` \ regb ->
3964 getNewRegNCG IntRep `thenNat` \ tmp ->
3965 let revinstr_avail = maybeToBool maybe_revinstr
3966 revinstr = case maybe_revinstr of Just ri -> ri
3970 then registerCode regb dst `bind` \ code_b ->
3972 revinstr (OpImm imm_a) (OpReg dst)
3973 else registerCodeF regb `bind` \ code_b ->
3974 registerNameF regb `bind` \ r_b ->
3976 MOV L (OpReg r_b) (OpReg dst) `snocOL`
3977 revinstr (OpImm imm_a) (OpReg dst)
3981 then registerCode regb tmp `bind` \ code_b ->
3983 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3984 instr (OpReg tmp) (OpReg dst)
3985 else registerCodeF regb `bind` \ code_b ->
3986 registerNameF regb `bind` \ r_b ->
3988 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3989 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3990 instr (OpReg tmp) (OpReg dst)
3992 returnNat (Any IntRep mkcode)
3995 = getRegister a `thenNat` \ rega ->
3996 getRegister b `thenNat` \ regb ->
3997 getNewRegNCG IntRep `thenNat` \ tmp ->
3999 = case (isAny rega, isAny regb) of
4001 -> registerCode regb tmp `bind` \ code_b ->
4002 registerCode rega dst `bind` \ code_a ->
4005 instr (OpReg tmp) (OpReg dst)
4007 -> registerCode rega tmp `bind` \ code_a ->
4008 registerCodeF regb `bind` \ code_b ->
4009 registerNameF regb `bind` \ r_b ->
4012 instr (OpReg r_b) (OpReg tmp) `snocOL`
4013 MOV L (OpReg tmp) (OpReg dst)
4015 -> registerCode regb tmp `bind` \ code_b ->
4016 registerCodeF rega `bind` \ code_a ->
4017 registerNameF rega `bind` \ r_a ->
4020 MOV L (OpReg r_a) (OpReg dst) `snocOL`
4021 instr (OpReg tmp) (OpReg dst)
4023 -> registerCodeF rega `bind` \ code_a ->
4024 registerNameF rega `bind` \ r_a ->
4025 registerCodeF regb `bind` \ code_b ->
4026 registerNameF regb `bind` \ r_b ->
4028 MOV L (OpReg r_a) (OpReg tmp) `appOL`
4030 instr (OpReg r_b) (OpReg tmp) `snocOL`
4031 MOV L (OpReg tmp) (OpReg dst)
4033 returnNat (Any IntRep mkcode)
4036 maybe_imm_a = maybeImm a
4037 is_imm_a = maybeToBool maybe_imm_a
4038 imm_a = case maybe_imm_a of Just imm -> imm
4040 maybe_imm_b = maybeImm b
4041 is_imm_b = maybeToBool maybe_imm_b
4042 imm_b = case maybe_imm_b of Just imm -> imm
4046 trivialUCode instr x
4047 = getRegister x `thenNat` \ register ->
4049 code__2 dst = let code = registerCode register dst
4050 src = registerName register dst
4052 if isFixed register && dst /= src
4053 then toOL [MOV L (OpReg src) (OpReg dst),
4055 else unitOL (instr (OpReg src))
4057 returnNat (Any IntRep code__2)
4060 trivialFCode pk instr x y
4061 = getRegister x `thenNat` \ register1 ->
4062 getRegister y `thenNat` \ register2 ->
4063 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
4064 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
4066 code1 = registerCode register1 tmp1
4067 src1 = registerName register1 tmp1
4069 code2 = registerCode register2 tmp2
4070 src2 = registerName register2 tmp2
4073 -- treat the common case specially: both operands in
4075 | isAny register1 && isAny register2
4078 instr (primRepToSize pk) src1 src2 dst
4080 -- be paranoid (and inefficient)
4082 = code1 `snocOL` GMOV src1 tmp1 `appOL`
4084 instr (primRepToSize pk) tmp1 src2 dst
4086 returnNat (Any pk code__2)
4090 trivialUFCode pk instr x
4091 = getRegister x `thenNat` \ register ->
4092 getNewRegNCG pk `thenNat` \ tmp ->
4094 code = registerCode register tmp
4095 src = registerName register tmp
4096 code__2 dst = code `snocOL` instr src dst
4098 returnNat (Any pk code__2)
4100 #endif /* i386_TARGET_ARCH */
4102 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4104 #if sparc_TARGET_ARCH
4106 trivialCode instr x (StInt y)
4108 = getRegister x `thenNat` \ register ->
4109 getNewRegNCG IntRep `thenNat` \ tmp ->
4111 code = registerCode register tmp
4112 src1 = registerName register tmp
4113 src2 = ImmInt (fromInteger y)
4114 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4116 returnNat (Any IntRep code__2)
4118 trivialCode instr x y
4119 = getRegister x `thenNat` \ register1 ->
4120 getRegister y `thenNat` \ register2 ->
4121 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4122 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4124 code1 = registerCode register1 tmp1
4125 src1 = registerName register1 tmp1
4126 code2 = registerCode register2 tmp2
4127 src2 = registerName register2 tmp2
4128 code__2 dst = code1 `appOL` code2 `snocOL`
4129 instr src1 (RIReg src2) dst
4131 returnNat (Any IntRep code__2)
4134 trivialFCode pk instr x y
4135 = getRegister x `thenNat` \ register1 ->
4136 getRegister y `thenNat` \ register2 ->
4137 getNewRegNCG (registerRep register1)
4139 getNewRegNCG (registerRep register2)
4141 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4143 promote x = FxTOy F DF x tmp
4145 pk1 = registerRep register1
4146 code1 = registerCode register1 tmp1
4147 src1 = registerName register1 tmp1
4149 pk2 = registerRep register2
4150 code2 = registerCode register2 tmp2
4151 src2 = registerName register2 tmp2
4155 code1 `appOL` code2 `snocOL`
4156 instr (primRepToSize pk) src1 src2 dst
4157 else if pk1 == FloatRep then
4158 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4159 instr DF tmp src2 dst
4161 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4162 instr DF src1 tmp dst
4164 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4167 trivialUCode instr x
4168 = getRegister x `thenNat` \ register ->
4169 getNewRegNCG IntRep `thenNat` \ tmp ->
4171 code = registerCode register tmp
4172 src = registerName register tmp
4173 code__2 dst = code `snocOL` instr (RIReg src) dst
4175 returnNat (Any IntRep code__2)
4178 trivialUFCode pk instr x
4179 = getRegister x `thenNat` \ register ->
4180 getNewRegNCG pk `thenNat` \ tmp ->
4182 code = registerCode register tmp
4183 src = registerName register tmp
4184 code__2 dst = code `snocOL` instr src dst
4186 returnNat (Any pk code__2)
4188 #endif /* sparc_TARGET_ARCH */
4190 #if powerpc_TARGET_ARCH
4191 trivialCode instr x (StInt y)
4193 = getRegister x `thenNat` \ register ->
4194 getNewRegNCG IntRep `thenNat` \ tmp ->
4196 code = registerCode register tmp
4197 src1 = registerName register tmp
4198 src2 = ImmInt (fromInteger y)
4199 code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4201 returnNat (Any IntRep code__2)
4203 trivialCode instr x y
4204 = getRegister x `thenNat` \ register1 ->
4205 getRegister y `thenNat` \ register2 ->
4206 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4207 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4209 code1 = registerCode register1 tmp1
4210 src1 = registerName register1 tmp1
4211 code2 = registerCode register2 tmp2
4212 src2 = registerName register2 tmp2
4213 code__2 dst = code1 `appOL` code2 `snocOL`
4214 instr dst src1 (RIReg src2)
4216 returnNat (Any IntRep code__2)
4218 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4219 -> StixExpr -> StixExpr -> NatM Register
4220 trivialCode2 instr x y
4221 = getRegister x `thenNat` \ register1 ->
4222 getRegister y `thenNat` \ register2 ->
4223 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4224 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4226 code1 = registerCode register1 tmp1
4227 src1 = registerName register1 tmp1
4228 code2 = registerCode register2 tmp2
4229 src2 = registerName register2 tmp2
4230 code__2 dst = code1 `appOL` code2 `snocOL`
4233 returnNat (Any IntRep code__2)
4235 trivialFCode pk instr x y
4236 = getRegister x `thenNat` \ register1 ->
4237 getRegister y `thenNat` \ register2 ->
4238 getNewRegNCG (registerRep register1)
4240 getNewRegNCG (registerRep register2)
4242 -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
4244 -- promote x = FxTOy F DF x tmp
4246 pk1 = registerRep register1
4247 code1 = registerCode register1 tmp1
4248 src1 = registerName register1 tmp1
4250 pk2 = registerRep register2
4251 code2 = registerCode register2 tmp2
4252 src2 = registerName register2 tmp2
4254 dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
4257 code1 `appOL` code2 `snocOL`
4258 instr (primRepToSize dstRep) dst src1 src2
4260 returnNat (Any dstRep code__2)
4262 trivialUCode instr x
4263 = getRegister x `thenNat` \ register ->
4264 getNewRegNCG IntRep `thenNat` \ tmp ->
4266 code = registerCode register tmp
4267 src = registerName register tmp
4268 code__2 dst = code `snocOL` instr dst src
4270 returnNat (Any IntRep code__2)
4271 trivialUFCode pk instr x
4272 = getRegister x `thenNat` \ register ->
4273 getNewRegNCG (registerRep register)
4276 code = registerCode register tmp
4277 src = registerName register tmp
4278 code__2 dst = code `snocOL` instr dst src
4280 returnNat (Any pk code__2)
4282 -- There is no "remainder" instruction on the PPC, so we have to do
4284 -- The "div" parameter is the division instruction to use (DIVW or DIVWU)
4286 remainderCode :: (Reg -> Reg -> Reg -> Instr)
4287 -> StixExpr -> StixExpr -> NatM Register
4288 remainderCode div x y
4289 = getRegister x `thenNat` \ register1 ->
4290 getRegister y `thenNat` \ register2 ->
4291 getNewRegNCG IntRep `thenNat` \ tmp1 ->
4292 getNewRegNCG IntRep `thenNat` \ tmp2 ->
4294 code1 = registerCode register1 tmp1
4295 src1 = registerName register1 tmp1
4296 code2 = registerCode register2 tmp2
4297 src2 = registerName register2 tmp2
4298 code__2 dst = code1 `appOL` code2 `appOL` toOL [
4300 MULLW dst dst (RIReg src2),
4304 returnNat (Any IntRep code__2)
4306 #endif /* powerpc_TARGET_ARCH */
4308 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4311 %************************************************************************
4313 \subsubsection{Coercing to/from integer/floating-point...}
4315 %************************************************************************
4317 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4318 conversions. We have to store temporaries in memory to move
4319 between the integer and the floating point register sets.
4321 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4322 pretend, on sparc at least, that double and float regs are seperate
4323 kinds, so the value has to be computed into one kind before being
4324 explicitly "converted" to live in the other kind.
4327 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4328 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4330 coerceDbl2Flt :: StixExpr -> NatM Register
4331 coerceFlt2Dbl :: StixExpr -> NatM Register
4335 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4337 #if alpha_TARGET_ARCH
4340 = getRegister x `thenNat` \ register ->
4341 getNewRegNCG IntRep `thenNat` \ reg ->
4343 code = registerCode register reg
4344 src = registerName register reg
4346 code__2 dst = code . mkSeqInstrs [
4348 LD TF dst (spRel 0),
4351 returnNat (Any DoubleRep code__2)
4355 = getRegister x `thenNat` \ register ->
4356 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4358 code = registerCode register tmp
4359 src = registerName register tmp
4361 code__2 dst = code . mkSeqInstrs [
4363 ST TF tmp (spRel 0),
4366 returnNat (Any IntRep code__2)
4368 #endif /* alpha_TARGET_ARCH */
4370 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4372 #if i386_TARGET_ARCH
4375 = getRegister x `thenNat` \ register ->
4376 getNewRegNCG IntRep `thenNat` \ reg ->
4378 code = registerCode register reg
4379 src = registerName register reg
4380 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4381 code__2 dst = code `snocOL` opc src dst
4383 returnNat (Any pk code__2)
4386 coerceFP2Int fprep x
4387 = getRegister x `thenNat` \ register ->
4388 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4390 code = registerCode register tmp
4391 src = registerName register tmp
4392 pk = registerRep register
4394 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4395 code__2 dst = code `snocOL` opc src dst
4397 returnNat (Any IntRep code__2)
4400 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4401 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4403 #endif /* i386_TARGET_ARCH */
4405 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4407 #if sparc_TARGET_ARCH
4410 = getRegister x `thenNat` \ register ->
4411 getNewRegNCG IntRep `thenNat` \ reg ->
4413 code = registerCode register reg
4414 src = registerName register reg
4416 code__2 dst = code `appOL` toOL [
4417 ST W src (spRel (-2)),
4418 LD W (spRel (-2)) dst,
4419 FxTOy W (primRepToSize pk) dst dst]
4421 returnNat (Any pk code__2)
4424 coerceFP2Int fprep x
4425 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4426 getRegister x `thenNat` \ register ->
4427 getNewRegNCG fprep `thenNat` \ reg ->
4428 getNewRegNCG FloatRep `thenNat` \ tmp ->
4430 code = registerCode register reg
4431 src = registerName register reg
4432 code__2 dst = code `appOL` toOL [
4433 FxTOy (primRepToSize fprep) W src tmp,
4434 ST W tmp (spRel (-2)),
4435 LD W (spRel (-2)) dst]
4437 returnNat (Any IntRep code__2)
4441 = getRegister x `thenNat` \ register ->
4442 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4443 let code = registerCode register tmp
4444 src = registerName register tmp
4446 returnNat (Any FloatRep
4447 (\dst -> code `snocOL` FxTOy DF F src dst))
4451 = getRegister x `thenNat` \ register ->
4452 getNewRegNCG FloatRep `thenNat` \ tmp ->
4453 let code = registerCode register tmp
4454 src = registerName register tmp
4456 returnNat (Any DoubleRep
4457 (\dst -> code `snocOL` FxTOy F DF src dst))
4459 #endif /* sparc_TARGET_ARCH */
4461 #if powerpc_TARGET_ARCH
4463 = ASSERT(pk == DoubleRep)
4464 getRegister x `thenNat` \ register ->
4465 getNewRegNCG IntRep `thenNat` \ reg ->
4466 getNatLabelNCG `thenNat` \ lbl ->
4467 getNewRegNCG PtrRep `thenNat` \ itmp ->
4468 getNewRegNCG DoubleRep `thenNat` \ ftmp ->
4470 code = registerCode register reg
4471 src = registerName register reg
4472 code__2 dst = code `appOL` toOL [
4473 SEGMENT RoDataSegment,
4475 DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
4476 SEGMENT TextSegment,
4477 XORIS itmp src (ImmInt 0x8000),
4478 ST W itmp (spRel (-1)),
4479 LIS itmp (ImmInt 0x4330),
4480 ST W itmp (spRel (-2)),
4481 LD DF ftmp (spRel (-2)),
4482 LIS itmp (HA (ImmCLbl lbl)),
4483 LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
4484 FSUB DF dst ftmp dst
4487 returnNat (Any DoubleRep code__2)
4489 coerceFP2Int fprep x
4490 = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4491 getRegister x `thenNat` \ register ->
4492 getNewRegNCG fprep `thenNat` \ reg ->
4493 getNewRegNCG DoubleRep `thenNat` \ tmp ->
4495 code = registerCode register reg
4496 src = registerName register reg
4497 code__2 dst = code `appOL` toOL [
4498 -- convert to int in FP reg
4500 -- store value (64bit) from FP to stack
4501 ST DF tmp (spRel (-2)),
4502 -- read low word of value (high word is undefined)
4503 LD W dst (spRel (-1))]
4505 returnNat (Any IntRep code__2)
4506 coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
4507 coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
4508 #endif /* powerpc_TARGET_ARCH */
4510 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -