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 ( stmt2Instrs, InstrBlock ) where
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
17 import MachMisc -- may differ per-platform
19 import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
20 snocOL, consOL, concatOL )
21 import AbsCUtils ( magicIdPrimRep )
22 import CallConv ( CallConv )
23 import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
24 import Maybes ( maybeToBool, expectJust )
25 import PrimRep ( isFloatingRep, PrimRep(..) )
26 import PrimOp ( PrimOp(..) )
27 import CallConv ( cCallConv )
28 import Stix ( getNatLabelNCG, StixTree(..),
29 StixReg(..), CodeSegment(..),
30 DestInfo, hasDestInfo,
31 pprStixTree, ppStixReg,
32 NatM, thenNat, returnNat, mapNat,
33 mapAndUnzipNat, mapAccumLNat,
34 getDeltaNat, setDeltaNat
37 import CmdLineOpts ( opt_Static )
43 @InstrBlock@s are the insn sequences generated by the insn selectors.
44 They are really trees of insns to facilitate fast appending, where a
45 left-to-right traversal (pre-order?) yields the insns in the correct
50 type InstrBlock = OrdList Instr
56 Code extractor for an entire stix tree---stix statement level.
59 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
61 stmt2Instrs stmt = case stmt of
62 StComment s -> returnNat (unitOL (COMMENT s))
63 StSegment seg -> returnNat (unitOL (SEGMENT seg))
65 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
67 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
70 StLabel lab -> returnNat (unitOL (LABEL lab))
72 StJump dsts arg -> genJump dsts (derefDLL arg)
73 StCondJump lab arg -> genCondJump lab (derefDLL arg)
75 -- A call returning void, ie one done for its side-effects
76 StCall fn cconv VoidRep args -> genCCall fn
77 cconv VoidRep (map derefDLL args)
80 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
81 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
84 -- When falling through on the Alpha, we still have to load pv
85 -- with the address of the next routine, so that it can load gp.
86 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
90 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
91 returnNat (DATA (primRepToSize kind) imms
92 `consOL` concatOL codes)
94 getData :: StixTree -> NatM (InstrBlock, Imm)
96 getData (StInt i) = returnNat (nilOL, ImmInteger i)
97 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
98 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
99 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
100 getData (StString s) =
101 getNatLabelNCG `thenNat` \ lbl ->
102 returnNat (toOL [LABEL lbl,
103 ASCII True (_UNPK_ s)],
105 -- the linker can handle simple arithmetic...
106 getData (StIndex rep (StCLbl lbl) (StInt off)) =
108 ImmIndex lbl (fromInteger (off * sizeOf rep)))
110 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
111 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
112 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
114 derefDLL :: StixTree -> StixTree
116 | opt_Static -- short out the entire deal if not doing DLLs
123 StCLbl lbl -> if labelDynamic lbl
124 then StInd PtrRep (StCLbl lbl)
126 -- all the rest are boring
127 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
128 StPrim pk args -> StPrim pk (map qq args)
129 StInd pk addr -> StInd pk (qq addr)
130 StCall who cc pk args -> StCall who cc pk (map qq args)
137 _ -> pprPanic "derefDLL: unhandled case"
141 %************************************************************************
143 \subsection{General things for putting together code sequences}
145 %************************************************************************
148 mangleIndexTree :: StixTree -> StixTree
150 mangleIndexTree (StIndex pk base (StInt i))
151 = StPrim IntAddOp [base, off]
153 off = StInt (i * sizeOf pk)
155 mangleIndexTree (StIndex pk base off)
159 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
160 if s == 0 then off else StPrim SllOp [off, StInt s]
163 shift DoubleRep = 3::Integer
164 shift CharRep = 2::Integer
165 shift Int8Rep = 0::Integer
166 shift _ = IF_ARCH_alpha(3,2)
170 maybeImm :: StixTree -> Maybe Imm
174 maybeImm (StIndex rep (StCLbl l) (StInt off))
175 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
177 | i >= toInteger minInt && i <= toInteger maxInt
178 = Just (ImmInt (fromInteger i))
180 = Just (ImmInteger i)
185 %************************************************************************
187 \subsection{The @Register@ type}
189 %************************************************************************
191 @Register@s passed up the tree. If the stix code forces the register
192 to live in a pre-decided machine register, it comes out as @Fixed@;
193 otherwise, it comes out as @Any@, and the parent can decide which
194 register to put it in.
198 = Fixed PrimRep Reg InstrBlock
199 | Any PrimRep (Reg -> InstrBlock)
201 registerCode :: Register -> Reg -> InstrBlock
202 registerCode (Fixed _ _ code) reg = code
203 registerCode (Any _ code) reg = code reg
205 registerCodeF (Fixed _ _ code) = code
206 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
208 registerCodeA (Any _ code) = code
209 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
211 registerName :: Register -> Reg -> Reg
212 registerName (Fixed _ reg _) _ = reg
213 registerName (Any _ _) reg = reg
215 registerNameF (Fixed _ reg _) = reg
216 registerNameF (Any _ _) = pprPanic "registerNameF" empty
218 registerRep :: Register -> PrimRep
219 registerRep (Fixed pk _ _) = pk
220 registerRep (Any pk _) = pk
222 {-# INLINE registerCode #-}
223 {-# INLINE registerCodeF #-}
224 {-# INLINE registerName #-}
225 {-# INLINE registerNameF #-}
226 {-# INLINE registerRep #-}
227 {-# INLINE isFixed #-}
230 isFixed, isAny :: Register -> Bool
231 isFixed (Fixed _ _ _) = True
232 isFixed (Any _ _) = False
234 isAny = not . isFixed
237 Generate code to get a subtree into a @Register@:
239 getRegister :: StixTree -> NatM Register
241 getRegister (StReg (StixMagicId stgreg))
242 = case (magicIdRegMaybe stgreg) of
243 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
246 getRegister (StReg (StixTemp u pk))
247 = returnNat (Fixed pk (mkVReg u pk) nilOL)
249 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
251 getRegister (StCall fn cconv kind args)
252 = genCCall fn cconv kind args `thenNat` \ call ->
253 returnNat (Fixed kind reg call)
255 reg = if isFloatingRep kind
256 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
257 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
259 getRegister (StString s)
260 = getNatLabelNCG `thenNat` \ lbl ->
262 imm_lbl = ImmCLbl lbl
267 ASCII True (_UNPK_ s),
269 #if alpha_TARGET_ARCH
270 LDA dst (AddrImm imm_lbl)
273 MOV L (OpImm imm_lbl) (OpReg dst)
275 #if sparc_TARGET_ARCH
276 SETHI (HI imm_lbl) dst,
277 OR False dst (RIImm (LO imm_lbl)) dst
281 returnNat (Any PtrRep code)
285 -- end of machine-"independent" bit; here we go on the rest...
287 #if alpha_TARGET_ARCH
289 getRegister (StDouble d)
290 = getNatLabelNCG `thenNat` \ lbl ->
291 getNewRegNCG PtrRep `thenNat` \ tmp ->
292 let code dst = mkSeqInstrs [
295 DATA TF [ImmLab (rational d)],
297 LDA tmp (AddrImm (ImmCLbl lbl)),
298 LD TF dst (AddrReg tmp)]
300 returnNat (Any DoubleRep code)
302 getRegister (StPrim primop [x]) -- unary PrimOps
304 IntNegOp -> trivialUCode (NEG Q False) x
306 NotOp -> trivialUCode NOT x
308 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
309 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
311 OrdOp -> coerceIntCode IntRep x
314 Float2IntOp -> coerceFP2Int x
315 Int2FloatOp -> coerceInt2FP pr x
316 Double2IntOp -> coerceFP2Int x
317 Int2DoubleOp -> coerceInt2FP pr x
319 Double2FloatOp -> coerceFltCode x
320 Float2DoubleOp -> coerceFltCode x
322 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
324 fn = case other_op of
325 FloatExpOp -> SLIT("exp")
326 FloatLogOp -> SLIT("log")
327 FloatSqrtOp -> SLIT("sqrt")
328 FloatSinOp -> SLIT("sin")
329 FloatCosOp -> SLIT("cos")
330 FloatTanOp -> SLIT("tan")
331 FloatAsinOp -> SLIT("asin")
332 FloatAcosOp -> SLIT("acos")
333 FloatAtanOp -> SLIT("atan")
334 FloatSinhOp -> SLIT("sinh")
335 FloatCoshOp -> SLIT("cosh")
336 FloatTanhOp -> SLIT("tanh")
337 DoubleExpOp -> SLIT("exp")
338 DoubleLogOp -> SLIT("log")
339 DoubleSqrtOp -> SLIT("sqrt")
340 DoubleSinOp -> SLIT("sin")
341 DoubleCosOp -> SLIT("cos")
342 DoubleTanOp -> SLIT("tan")
343 DoubleAsinOp -> SLIT("asin")
344 DoubleAcosOp -> SLIT("acos")
345 DoubleAtanOp -> SLIT("atan")
346 DoubleSinhOp -> SLIT("sinh")
347 DoubleCoshOp -> SLIT("cosh")
348 DoubleTanhOp -> SLIT("tanh")
350 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
352 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
354 CharGtOp -> trivialCode (CMP LTT) y x
355 CharGeOp -> trivialCode (CMP LE) y x
356 CharEqOp -> trivialCode (CMP EQQ) x y
357 CharNeOp -> int_NE_code x y
358 CharLtOp -> trivialCode (CMP LTT) x y
359 CharLeOp -> trivialCode (CMP LE) x y
361 IntGtOp -> trivialCode (CMP LTT) y x
362 IntGeOp -> trivialCode (CMP LE) y x
363 IntEqOp -> trivialCode (CMP EQQ) x y
364 IntNeOp -> int_NE_code x y
365 IntLtOp -> trivialCode (CMP LTT) x y
366 IntLeOp -> trivialCode (CMP LE) x y
368 WordGtOp -> trivialCode (CMP ULT) y x
369 WordGeOp -> trivialCode (CMP ULE) x y
370 WordEqOp -> trivialCode (CMP EQQ) x y
371 WordNeOp -> int_NE_code x y
372 WordLtOp -> trivialCode (CMP ULT) x y
373 WordLeOp -> trivialCode (CMP ULE) x y
375 AddrGtOp -> trivialCode (CMP ULT) y x
376 AddrGeOp -> trivialCode (CMP ULE) y x
377 AddrEqOp -> trivialCode (CMP EQQ) x y
378 AddrNeOp -> int_NE_code x y
379 AddrLtOp -> trivialCode (CMP ULT) x y
380 AddrLeOp -> trivialCode (CMP ULE) x y
382 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
383 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
384 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
385 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
386 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
387 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
389 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
390 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
391 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
392 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
393 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
394 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
396 IntAddOp -> trivialCode (ADD Q False) x y
397 IntSubOp -> trivialCode (SUB Q False) x y
398 IntMulOp -> trivialCode (MUL Q False) x y
399 IntQuotOp -> trivialCode (DIV Q False) x y
400 IntRemOp -> trivialCode (REM Q False) x y
402 WordQuotOp -> trivialCode (DIV Q True) x y
403 WordRemOp -> trivialCode (REM Q True) x y
405 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
406 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
407 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
408 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
410 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
411 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
412 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
413 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
415 AndOp -> trivialCode AND x y
416 OrOp -> trivialCode OR x y
417 XorOp -> trivialCode XOR x y
418 SllOp -> trivialCode SLL x y
419 SrlOp -> trivialCode SRL x y
421 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
422 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
423 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
425 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
426 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
428 {- ------------------------------------------------------------
429 Some bizarre special code for getting condition codes into
430 registers. Integer non-equality is a test for equality
431 followed by an XOR with 1. (Integer comparisons always set
432 the result register to 0 or 1.) Floating point comparisons of
433 any kind leave the result in a floating point register, so we
434 need to wrangle an integer register out of things.
436 int_NE_code :: StixTree -> StixTree -> NatM Register
439 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
440 getNewRegNCG IntRep `thenNat` \ tmp ->
442 code = registerCode register tmp
443 src = registerName register tmp
444 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
446 returnNat (Any IntRep code__2)
448 {- ------------------------------------------------------------
449 Comments for int_NE_code also apply to cmpF_code
452 :: (Reg -> Reg -> Reg -> Instr)
454 -> StixTree -> StixTree
457 cmpF_code instr cond x y
458 = trivialFCode pr instr x y `thenNat` \ register ->
459 getNewRegNCG DoubleRep `thenNat` \ tmp ->
460 getNatLabelNCG `thenNat` \ lbl ->
462 code = registerCode register tmp
463 result = registerName register tmp
465 code__2 dst = code . mkSeqInstrs [
466 OR zeroh (RIImm (ImmInt 1)) dst,
467 BF cond result (ImmCLbl lbl),
468 OR zeroh (RIReg zeroh) dst,
471 returnNat (Any IntRep code__2)
473 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
474 ------------------------------------------------------------
476 getRegister (StInd pk mem)
477 = getAmode mem `thenNat` \ amode ->
479 code = amodeCode amode
480 src = amodeAddr amode
481 size = primRepToSize pk
482 code__2 dst = code . mkSeqInstr (LD size dst src)
484 returnNat (Any pk code__2)
486 getRegister (StInt i)
489 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
491 returnNat (Any IntRep code)
494 code dst = mkSeqInstr (LDI Q dst src)
496 returnNat (Any IntRep code)
498 src = ImmInt (fromInteger i)
503 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
505 returnNat (Any PtrRep code)
508 imm__2 = case imm of Just x -> x
510 #endif {- alpha_TARGET_ARCH -}
511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
514 getRegister (StFloat f)
515 = getNatLabelNCG `thenNat` \ lbl ->
516 let code dst = toOL [
521 GLD F (ImmAddr (ImmCLbl lbl) 0) dst
524 returnNat (Any FloatRep code)
527 getRegister (StDouble d)
530 = let code dst = unitOL (GLDZ dst)
531 in returnNat (Any DoubleRep code)
534 = let code dst = unitOL (GLD1 dst)
535 in returnNat (Any DoubleRep code)
538 = getNatLabelNCG `thenNat` \ lbl ->
539 let code dst = toOL [
542 DATA DF [ImmDouble d],
544 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
547 returnNat (Any DoubleRep code)
549 -- Calculate the offset for (i+1) words above the _initial_
550 -- %esp value by first determining the current offset of it.
551 getRegister (StScratchWord i)
553 = getDeltaNat `thenNat` \ current_stack_offset ->
554 let j = i+1 - (current_stack_offset `div` 4)
556 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
558 returnNat (Any PtrRep code)
560 getRegister (StPrim primop [x]) -- unary PrimOps
562 IntNegOp -> trivialUCode (NEGI L) x
563 NotOp -> trivialUCode (NOT L) x
565 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
566 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
568 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
569 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
571 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
572 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
574 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
575 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
577 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
578 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
580 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
581 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
583 OrdOp -> coerceIntCode IntRep x
586 Float2IntOp -> coerceFP2Int x
587 Int2FloatOp -> coerceInt2FP FloatRep x
588 Double2IntOp -> coerceFP2Int x
589 Int2DoubleOp -> coerceInt2FP DoubleRep x
592 getRegister (StCall fn cCallConv DoubleRep [x])
596 FloatExpOp -> (True, SLIT("exp"))
597 FloatLogOp -> (True, SLIT("log"))
599 FloatAsinOp -> (True, SLIT("asin"))
600 FloatAcosOp -> (True, SLIT("acos"))
601 FloatAtanOp -> (True, SLIT("atan"))
603 FloatSinhOp -> (True, SLIT("sinh"))
604 FloatCoshOp -> (True, SLIT("cosh"))
605 FloatTanhOp -> (True, SLIT("tanh"))
607 DoubleExpOp -> (False, SLIT("exp"))
608 DoubleLogOp -> (False, SLIT("log"))
610 DoubleAsinOp -> (False, SLIT("asin"))
611 DoubleAcosOp -> (False, SLIT("acos"))
612 DoubleAtanOp -> (False, SLIT("atan"))
614 DoubleSinhOp -> (False, SLIT("sinh"))
615 DoubleCoshOp -> (False, SLIT("cosh"))
616 DoubleTanhOp -> (False, SLIT("tanh"))
619 -> pprPanic "getRegister(x86,unary primop)"
620 (pprStixTree (StPrim primop [x]))
622 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
624 CharGtOp -> condIntReg GTT x y
625 CharGeOp -> condIntReg GE x y
626 CharEqOp -> condIntReg EQQ x y
627 CharNeOp -> condIntReg NE x y
628 CharLtOp -> condIntReg LTT x y
629 CharLeOp -> condIntReg LE x y
631 IntGtOp -> condIntReg GTT x y
632 IntGeOp -> condIntReg GE x y
633 IntEqOp -> condIntReg EQQ x y
634 IntNeOp -> condIntReg NE x y
635 IntLtOp -> condIntReg LTT x y
636 IntLeOp -> condIntReg LE x y
638 WordGtOp -> condIntReg GU x y
639 WordGeOp -> condIntReg GEU x y
640 WordEqOp -> condIntReg EQQ x y
641 WordNeOp -> condIntReg NE x y
642 WordLtOp -> condIntReg LU x y
643 WordLeOp -> condIntReg LEU x y
645 AddrGtOp -> condIntReg GU x y
646 AddrGeOp -> condIntReg GEU x y
647 AddrEqOp -> condIntReg EQQ x y
648 AddrNeOp -> condIntReg NE x y
649 AddrLtOp -> condIntReg LU x y
650 AddrLeOp -> condIntReg LEU x y
652 FloatGtOp -> condFltReg GTT x y
653 FloatGeOp -> condFltReg GE x y
654 FloatEqOp -> condFltReg EQQ x y
655 FloatNeOp -> condFltReg NE x y
656 FloatLtOp -> condFltReg LTT x y
657 FloatLeOp -> condFltReg LE x y
659 DoubleGtOp -> condFltReg GTT x y
660 DoubleGeOp -> condFltReg GE x y
661 DoubleEqOp -> condFltReg EQQ x y
662 DoubleNeOp -> condFltReg NE x y
663 DoubleLtOp -> condFltReg LTT x y
664 DoubleLeOp -> condFltReg LE x y
666 IntAddOp -> add_code L x y
667 IntSubOp -> sub_code L x y
668 IntQuotOp -> quot_code L x y True{-division-}
669 IntRemOp -> quot_code L x y False{-remainder-}
670 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
672 FloatAddOp -> trivialFCode FloatRep GADD x y
673 FloatSubOp -> trivialFCode FloatRep GSUB x y
674 FloatMulOp -> trivialFCode FloatRep GMUL x y
675 FloatDivOp -> trivialFCode FloatRep GDIV x y
677 DoubleAddOp -> trivialFCode DoubleRep GADD x y
678 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
679 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
680 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
682 AndOp -> let op = AND L in trivialCode op (Just op) x y
683 OrOp -> let op = OR L in trivialCode op (Just op) x y
684 XorOp -> let op = XOR L in trivialCode op (Just op) x y
686 {- Shift ops on x86s have constraints on their source, it
687 either has to be Imm, CL or 1
688 => trivialCode's is not restrictive enough (sigh.)
691 SllOp -> shift_code (SHL L) x y {-False-}
692 SrlOp -> shift_code (SHR L) x y {-False-}
693 ISllOp -> shift_code (SHL L) x y {-False-}
694 ISraOp -> shift_code (SAR L) x y {-False-}
695 ISrlOp -> shift_code (SHR L) x y {-False-}
697 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
698 [promote x, promote y])
699 where promote x = StPrim Float2DoubleOp [x]
700 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
703 -> pprPanic "getRegister(x86,dyadic primop)"
704 (pprStixTree (StPrim primop [x, y]))
708 shift_code :: (Imm -> Operand -> Instr)
713 {- Case1: shift length as immediate -}
714 -- Code is the same as the first eq. for trivialCode -- sigh.
715 shift_code instr x y{-amount-}
717 = getRegister x `thenNat` \ regx ->
720 then registerCodeA regx dst `bind` \ code_x ->
722 instr imm__2 (OpReg dst)
723 else registerCodeF regx `bind` \ code_x ->
724 registerNameF regx `bind` \ r_x ->
726 MOV L (OpReg r_x) (OpReg dst) `snocOL`
727 instr imm__2 (OpReg dst)
729 returnNat (Any IntRep mkcode)
732 imm__2 = case imm of Just x -> x
734 {- Case2: shift length is complex (non-immediate) -}
735 -- Since ECX is always used as a spill temporary, we can't
736 -- use it here to do non-immediate shifts. No big deal --
737 -- they are only very rare, and we can use an equivalent
738 -- test-and-jump sequence which doesn't use ECX.
739 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
740 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
741 shift_code instr x y{-amount-}
742 = getRegister x `thenNat` \ register1 ->
743 getRegister y `thenNat` \ register2 ->
744 getNatLabelNCG `thenNat` \ lbl_test3 ->
745 getNatLabelNCG `thenNat` \ lbl_test2 ->
746 getNatLabelNCG `thenNat` \ lbl_test1 ->
747 getNatLabelNCG `thenNat` \ lbl_test0 ->
748 getNatLabelNCG `thenNat` \ lbl_after ->
749 getNewRegNCG IntRep `thenNat` \ tmp ->
751 = let src_val = registerName register1 dst
752 code_val = registerCode register1 dst
753 src_amt = registerName register2 tmp
754 code_amt = registerCode register2 tmp
759 MOV L (OpReg src_amt) r_tmp `appOL`
761 MOV L (OpReg src_val) r_dst `appOL`
763 COMMENT (_PK_ "begin shift sequence"),
764 MOV L (OpReg src_val) r_dst,
765 MOV L (OpReg src_amt) r_tmp,
767 BT L (ImmInt 4) r_tmp,
769 instr (ImmInt 16) r_dst,
772 BT L (ImmInt 3) r_tmp,
774 instr (ImmInt 8) r_dst,
777 BT L (ImmInt 2) r_tmp,
779 instr (ImmInt 4) r_dst,
782 BT L (ImmInt 1) r_tmp,
784 instr (ImmInt 2) r_dst,
787 BT L (ImmInt 0) r_tmp,
789 instr (ImmInt 1) r_dst,
792 COMMENT (_PK_ "end shift sequence")
795 returnNat (Any IntRep code__2)
798 add_code :: Size -> StixTree -> StixTree -> NatM Register
800 add_code sz x (StInt y)
801 = getRegister x `thenNat` \ register ->
802 getNewRegNCG IntRep `thenNat` \ tmp ->
804 code = registerCode register tmp
805 src1 = registerName register tmp
806 src2 = ImmInt (fromInteger y)
809 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
812 returnNat (Any IntRep code__2)
814 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
817 sub_code :: Size -> StixTree -> StixTree -> NatM Register
819 sub_code sz x (StInt y)
820 = getRegister x `thenNat` \ register ->
821 getNewRegNCG IntRep `thenNat` \ tmp ->
823 code = registerCode register tmp
824 src1 = registerName register tmp
825 src2 = ImmInt (-(fromInteger y))
828 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
831 returnNat (Any IntRep code__2)
833 sub_code sz x y = trivialCode (SUB sz) Nothing x y
838 -> StixTree -> StixTree
839 -> Bool -- True => division, False => remainder operation
842 -- x must go into eax, edx must be a sign-extension of eax, and y
843 -- should go in some other register (or memory), so that we get
844 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
845 -- to put y on the C stack, since that avoids tying up yet another
846 -- precious register.
848 quot_code sz x y is_division
849 = getRegister x `thenNat` \ register1 ->
850 getRegister y `thenNat` \ register2 ->
851 getNewRegNCG IntRep `thenNat` \ tmp ->
852 getDeltaNat `thenNat` \ delta ->
854 code1 = registerCode register1 tmp
855 src1 = registerName register1 tmp
856 code2 = registerCode register2 tmp
857 src2 = registerName register2 tmp
858 code__2 = code2 `snocOL` -- src2 := y
859 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
860 DELTA (delta-4) `appOL`
861 code1 `snocOL` -- src1 := x
862 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
864 IDIV sz (OpAddr (spRel 0)) `snocOL`
865 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
868 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
869 -----------------------
871 getRegister (StInd pk mem)
872 = getAmode mem `thenNat` \ amode ->
874 code = amodeCode amode
875 src = amodeAddr amode
876 size = primRepToSize pk
877 code__2 dst = code `snocOL`
878 if pk == DoubleRep || pk == FloatRep
879 then GLD size src dst
881 L -> MOV L (OpAddr src) (OpReg dst)
882 B -> MOVZxL B (OpAddr src) (OpReg dst)
884 returnNat (Any pk code__2)
886 getRegister (StInt i)
888 src = ImmInt (fromInteger i)
891 = unitOL (XOR L (OpReg dst) (OpReg dst))
893 = unitOL (MOV L (OpImm src) (OpReg dst))
895 returnNat (Any IntRep code)
899 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
901 returnNat (Any PtrRep code)
903 = pprPanic "getRegister(x86)" (pprStixTree leaf)
906 imm__2 = case imm of Just x -> x
908 #endif {- i386_TARGET_ARCH -}
909 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
910 #if sparc_TARGET_ARCH
912 getRegister (StFloat d)
913 = getNatLabelNCG `thenNat` \ lbl ->
914 getNewRegNCG PtrRep `thenNat` \ tmp ->
915 let code dst = toOL [
920 SETHI (HI (ImmCLbl lbl)) tmp,
921 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
923 returnNat (Any FloatRep code)
925 getRegister (StDouble d)
926 = getNatLabelNCG `thenNat` \ lbl ->
927 getNewRegNCG PtrRep `thenNat` \ tmp ->
928 let code dst = toOL [
931 DATA DF [ImmDouble d],
933 SETHI (HI (ImmCLbl lbl)) tmp,
934 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
936 returnNat (Any DoubleRep code)
938 -- The 6-word scratch area is immediately below the frame pointer.
939 -- Below that is the spill area.
940 getRegister (StScratchWord i)
943 code dst = unitOL (fpRelEA j dst)
945 returnNat (Any PtrRep code)
948 getRegister (StPrim primop [x]) -- unary PrimOps
950 IntNegOp -> trivialUCode (SUB False False g0) x
951 NotOp -> trivialUCode (XNOR False g0) x
953 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
954 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
956 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
958 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
959 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
961 OrdOp -> coerceIntCode IntRep x
964 Float2IntOp -> coerceFP2Int x
965 Int2FloatOp -> coerceInt2FP FloatRep x
966 Double2IntOp -> coerceFP2Int x
967 Int2DoubleOp -> coerceInt2FP DoubleRep x
971 fixed_x = if is_float_op -- promote to double
972 then StPrim Float2DoubleOp [x]
975 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
979 FloatExpOp -> (True, SLIT("exp"))
980 FloatLogOp -> (True, SLIT("log"))
981 FloatSqrtOp -> (True, SLIT("sqrt"))
983 FloatSinOp -> (True, SLIT("sin"))
984 FloatCosOp -> (True, SLIT("cos"))
985 FloatTanOp -> (True, SLIT("tan"))
987 FloatAsinOp -> (True, SLIT("asin"))
988 FloatAcosOp -> (True, SLIT("acos"))
989 FloatAtanOp -> (True, SLIT("atan"))
991 FloatSinhOp -> (True, SLIT("sinh"))
992 FloatCoshOp -> (True, SLIT("cosh"))
993 FloatTanhOp -> (True, SLIT("tanh"))
995 DoubleExpOp -> (False, SLIT("exp"))
996 DoubleLogOp -> (False, SLIT("log"))
997 DoubleSqrtOp -> (False, SLIT("sqrt"))
999 DoubleSinOp -> (False, SLIT("sin"))
1000 DoubleCosOp -> (False, SLIT("cos"))
1001 DoubleTanOp -> (False, SLIT("tan"))
1003 DoubleAsinOp -> (False, SLIT("asin"))
1004 DoubleAcosOp -> (False, SLIT("acos"))
1005 DoubleAtanOp -> (False, SLIT("atan"))
1007 DoubleSinhOp -> (False, SLIT("sinh"))
1008 DoubleCoshOp -> (False, SLIT("cosh"))
1009 DoubleTanhOp -> (False, SLIT("tanh"))
1012 -> pprPanic "getRegister(sparc,monadicprimop)"
1013 (pprStixTree (StPrim primop [x]))
1015 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1017 CharGtOp -> condIntReg GTT x y
1018 CharGeOp -> condIntReg GE x y
1019 CharEqOp -> condIntReg EQQ x y
1020 CharNeOp -> condIntReg NE x y
1021 CharLtOp -> condIntReg LTT x y
1022 CharLeOp -> condIntReg LE x y
1024 IntGtOp -> condIntReg GTT x y
1025 IntGeOp -> condIntReg GE x y
1026 IntEqOp -> condIntReg EQQ x y
1027 IntNeOp -> condIntReg NE x y
1028 IntLtOp -> condIntReg LTT x y
1029 IntLeOp -> condIntReg LE x y
1031 WordGtOp -> condIntReg GU x y
1032 WordGeOp -> condIntReg GEU x y
1033 WordEqOp -> condIntReg EQQ x y
1034 WordNeOp -> condIntReg NE x y
1035 WordLtOp -> condIntReg LU x y
1036 WordLeOp -> condIntReg LEU x y
1038 AddrGtOp -> condIntReg GU x y
1039 AddrGeOp -> condIntReg GEU x y
1040 AddrEqOp -> condIntReg EQQ x y
1041 AddrNeOp -> condIntReg NE x y
1042 AddrLtOp -> condIntReg LU x y
1043 AddrLeOp -> condIntReg LEU x y
1045 FloatGtOp -> condFltReg GTT x y
1046 FloatGeOp -> condFltReg GE x y
1047 FloatEqOp -> condFltReg EQQ x y
1048 FloatNeOp -> condFltReg NE x y
1049 FloatLtOp -> condFltReg LTT x y
1050 FloatLeOp -> condFltReg LE x y
1052 DoubleGtOp -> condFltReg GTT x y
1053 DoubleGeOp -> condFltReg GE x y
1054 DoubleEqOp -> condFltReg EQQ x y
1055 DoubleNeOp -> condFltReg NE x y
1056 DoubleLtOp -> condFltReg LTT x y
1057 DoubleLeOp -> condFltReg LE x y
1059 IntAddOp -> trivialCode (ADD False False) x y
1060 IntSubOp -> trivialCode (SUB False False) x y
1062 -- ToDo: teach about V8+ SPARC mul/div instructions
1063 IntMulOp -> imul_div SLIT(".umul") x y
1064 IntQuotOp -> imul_div SLIT(".div") x y
1065 IntRemOp -> imul_div SLIT(".rem") x y
1067 FloatAddOp -> trivialFCode FloatRep FADD x y
1068 FloatSubOp -> trivialFCode FloatRep FSUB x y
1069 FloatMulOp -> trivialFCode FloatRep FMUL x y
1070 FloatDivOp -> trivialFCode FloatRep FDIV x y
1072 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1073 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1074 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1075 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1077 AndOp -> trivialCode (AND False) x y
1078 OrOp -> trivialCode (OR False) x y
1079 XorOp -> trivialCode (XOR False) x y
1080 SllOp -> trivialCode SLL x y
1081 SrlOp -> trivialCode SRL x y
1083 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1084 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1085 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1087 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1088 [promote x, promote y])
1089 where promote x = StPrim Float2DoubleOp [x]
1090 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1094 -> pprPanic "getRegister(sparc,dyadic primop)"
1095 (pprStixTree (StPrim primop [x, y]))
1098 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1100 getRegister (StInd pk mem)
1101 = getAmode mem `thenNat` \ amode ->
1103 code = amodeCode amode
1104 src = amodeAddr amode
1105 size = primRepToSize pk
1106 code__2 dst = code `snocOL` LD size src dst
1108 returnNat (Any pk code__2)
1110 getRegister (StInt i)
1113 src = ImmInt (fromInteger i)
1114 code dst = unitOL (OR False g0 (RIImm src) dst)
1116 returnNat (Any IntRep code)
1122 SETHI (HI imm__2) dst,
1123 OR False dst (RIImm (LO imm__2)) dst]
1125 returnNat (Any PtrRep code)
1127 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1130 imm__2 = case imm of Just x -> x
1132 #endif {- sparc_TARGET_ARCH -}
1135 %************************************************************************
1137 \subsection{The @Amode@ type}
1139 %************************************************************************
1141 @Amode@s: Memory addressing modes passed up the tree.
1143 data Amode = Amode MachRegsAddr InstrBlock
1145 amodeAddr (Amode addr _) = addr
1146 amodeCode (Amode _ code) = code
1149 Now, given a tree (the argument to an StInd) that references memory,
1150 produce a suitable addressing mode.
1152 A Rule of the Game (tm) for Amodes: use of the addr bit must
1153 immediately follow use of the code part, since the code part puts
1154 values in registers which the addr then refers to. So you can't put
1155 anything in between, lest it overwrite some of those registers. If
1156 you need to do some other computation between the code part and use of
1157 the addr bit, first store the effective address from the amode in a
1158 temporary, then do the other computation, and then use the temporary:
1162 ... other computation ...
1166 getAmode :: StixTree -> NatM Amode
1168 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1170 #if alpha_TARGET_ARCH
1172 getAmode (StPrim IntSubOp [x, StInt i])
1173 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1174 getRegister x `thenNat` \ register ->
1176 code = registerCode register tmp
1177 reg = registerName register tmp
1178 off = ImmInt (-(fromInteger i))
1180 returnNat (Amode (AddrRegImm reg off) code)
1182 getAmode (StPrim IntAddOp [x, StInt i])
1183 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1184 getRegister x `thenNat` \ register ->
1186 code = registerCode register tmp
1187 reg = registerName register tmp
1188 off = ImmInt (fromInteger i)
1190 returnNat (Amode (AddrRegImm reg off) code)
1194 = returnNat (Amode (AddrImm imm__2) id)
1197 imm__2 = case imm of Just x -> x
1200 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1201 getRegister other `thenNat` \ register ->
1203 code = registerCode register tmp
1204 reg = registerName register tmp
1206 returnNat (Amode (AddrReg reg) code)
1208 #endif {- alpha_TARGET_ARCH -}
1209 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1210 #if i386_TARGET_ARCH
1212 getAmode (StPrim IntSubOp [x, StInt i])
1213 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1214 getRegister x `thenNat` \ register ->
1216 code = registerCode register tmp
1217 reg = registerName register tmp
1218 off = ImmInt (-(fromInteger i))
1220 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1222 getAmode (StPrim IntAddOp [x, StInt i])
1224 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1227 imm__2 = case imm of Just x -> x
1229 getAmode (StPrim IntAddOp [x, StInt i])
1230 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1231 getRegister x `thenNat` \ register ->
1233 code = registerCode register tmp
1234 reg = registerName register tmp
1235 off = ImmInt (fromInteger i)
1237 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1239 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1240 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1241 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1242 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1243 getRegister x `thenNat` \ register1 ->
1244 getRegister y `thenNat` \ register2 ->
1246 code1 = registerCode register1 tmp1
1247 reg1 = registerName register1 tmp1
1248 code2 = registerCode register2 tmp2
1249 reg2 = registerName register2 tmp2
1250 code__2 = code1 `appOL` code2
1251 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1253 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1258 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1261 imm__2 = case imm of Just x -> x
1264 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1265 getRegister other `thenNat` \ register ->
1267 code = registerCode register tmp
1268 reg = registerName register tmp
1270 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1272 #endif {- i386_TARGET_ARCH -}
1273 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1274 #if sparc_TARGET_ARCH
1276 getAmode (StPrim IntSubOp [x, StInt i])
1278 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1279 getRegister x `thenNat` \ register ->
1281 code = registerCode register tmp
1282 reg = registerName register tmp
1283 off = ImmInt (-(fromInteger i))
1285 returnNat (Amode (AddrRegImm reg off) code)
1288 getAmode (StPrim IntAddOp [x, StInt i])
1290 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1291 getRegister x `thenNat` \ register ->
1293 code = registerCode register tmp
1294 reg = registerName register tmp
1295 off = ImmInt (fromInteger i)
1297 returnNat (Amode (AddrRegImm reg off) code)
1299 getAmode (StPrim IntAddOp [x, y])
1300 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1301 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1302 getRegister x `thenNat` \ register1 ->
1303 getRegister y `thenNat` \ register2 ->
1305 code1 = registerCode register1 tmp1
1306 reg1 = registerName register1 tmp1
1307 code2 = registerCode register2 tmp2
1308 reg2 = registerName register2 tmp2
1309 code__2 = code1 `appOL` code2
1311 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1315 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1317 code = unitOL (SETHI (HI imm__2) tmp)
1319 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1322 imm__2 = case imm of Just x -> x
1325 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1326 getRegister other `thenNat` \ register ->
1328 code = registerCode register tmp
1329 reg = registerName register tmp
1332 returnNat (Amode (AddrRegImm reg off) code)
1334 #endif {- sparc_TARGET_ARCH -}
1337 %************************************************************************
1339 \subsection{The @CondCode@ type}
1341 %************************************************************************
1343 Condition codes passed up the tree.
1345 data CondCode = CondCode Bool Cond InstrBlock
1347 condName (CondCode _ cond _) = cond
1348 condFloat (CondCode is_float _ _) = is_float
1349 condCode (CondCode _ _ code) = code
1352 Set up a condition code for a conditional branch.
1355 getCondCode :: StixTree -> NatM CondCode
1357 #if alpha_TARGET_ARCH
1358 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1359 #endif {- alpha_TARGET_ARCH -}
1360 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1362 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1363 -- yes, they really do seem to want exactly the same!
1365 getCondCode (StPrim primop [x, y])
1367 CharGtOp -> condIntCode GTT x y
1368 CharGeOp -> condIntCode GE x y
1369 CharEqOp -> condIntCode EQQ x y
1370 CharNeOp -> condIntCode NE x y
1371 CharLtOp -> condIntCode LTT x y
1372 CharLeOp -> condIntCode LE x y
1374 IntGtOp -> condIntCode GTT x y
1375 IntGeOp -> condIntCode GE x y
1376 IntEqOp -> condIntCode EQQ x y
1377 IntNeOp -> condIntCode NE x y
1378 IntLtOp -> condIntCode LTT x y
1379 IntLeOp -> condIntCode LE x y
1381 WordGtOp -> condIntCode GU x y
1382 WordGeOp -> condIntCode GEU x y
1383 WordEqOp -> condIntCode EQQ x y
1384 WordNeOp -> condIntCode NE x y
1385 WordLtOp -> condIntCode LU x y
1386 WordLeOp -> condIntCode LEU x y
1388 AddrGtOp -> condIntCode GU x y
1389 AddrGeOp -> condIntCode GEU x y
1390 AddrEqOp -> condIntCode EQQ x y
1391 AddrNeOp -> condIntCode NE x y
1392 AddrLtOp -> condIntCode LU x y
1393 AddrLeOp -> condIntCode LEU x y
1395 FloatGtOp -> condFltCode GTT x y
1396 FloatGeOp -> condFltCode GE x y
1397 FloatEqOp -> condFltCode EQQ x y
1398 FloatNeOp -> condFltCode NE x y
1399 FloatLtOp -> condFltCode LTT x y
1400 FloatLeOp -> condFltCode LE x y
1402 DoubleGtOp -> condFltCode GTT x y
1403 DoubleGeOp -> condFltCode GE x y
1404 DoubleEqOp -> condFltCode EQQ x y
1405 DoubleNeOp -> condFltCode NE x y
1406 DoubleLtOp -> condFltCode LTT x y
1407 DoubleLeOp -> condFltCode LE x y
1409 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1414 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1415 passed back up the tree.
1418 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1420 #if alpha_TARGET_ARCH
1421 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1422 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1423 #endif {- alpha_TARGET_ARCH -}
1425 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1426 #if i386_TARGET_ARCH
1428 -- memory vs immediate
1429 condIntCode cond (StInd pk x) y
1431 = getAmode x `thenNat` \ amode ->
1433 code1 = amodeCode amode
1434 x__2 = amodeAddr amode
1435 sz = primRepToSize pk
1436 code__2 = code1 `snocOL`
1437 CMP sz (OpImm imm__2) (OpAddr x__2)
1439 returnNat (CondCode False cond code__2)
1442 imm__2 = case imm of Just x -> x
1445 condIntCode cond x (StInt 0)
1446 = getRegister x `thenNat` \ register1 ->
1447 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1449 code1 = registerCode register1 tmp1
1450 src1 = registerName register1 tmp1
1451 code__2 = code1 `snocOL`
1452 TEST L (OpReg src1) (OpReg src1)
1454 returnNat (CondCode False cond code__2)
1456 -- anything vs immediate
1457 condIntCode cond x y
1459 = getRegister x `thenNat` \ register1 ->
1460 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1462 code1 = registerCode register1 tmp1
1463 src1 = registerName register1 tmp1
1464 code__2 = code1 `snocOL`
1465 CMP L (OpImm imm__2) (OpReg src1)
1467 returnNat (CondCode False cond code__2)
1470 imm__2 = case imm of Just x -> x
1472 -- memory vs anything
1473 condIntCode cond (StInd pk x) y
1474 = getAmode x `thenNat` \ amode_x ->
1475 getRegister y `thenNat` \ reg_y ->
1476 getNewRegNCG IntRep `thenNat` \ tmp ->
1478 c_x = amodeCode amode_x
1479 am_x = amodeAddr amode_x
1480 c_y = registerCode reg_y tmp
1481 r_y = registerName reg_y tmp
1482 sz = primRepToSize pk
1484 -- optimisation: if there's no code for x, just an amode,
1485 -- use whatever reg y winds up in. Assumes that c_y doesn't
1486 -- clobber any regs in the amode am_x, which I'm not sure is
1487 -- justified. The otherwise clause makes the same assumption.
1488 code__2 | isNilOL c_x
1490 CMP sz (OpReg r_y) (OpAddr am_x)
1494 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1496 CMP sz (OpReg tmp) (OpAddr am_x)
1498 returnNat (CondCode False cond code__2)
1500 -- anything vs memory
1502 condIntCode cond y (StInd pk x)
1503 = getAmode x `thenNat` \ amode_x ->
1504 getRegister y `thenNat` \ reg_y ->
1505 getNewRegNCG IntRep `thenNat` \ tmp ->
1507 c_x = amodeCode amode_x
1508 am_x = amodeAddr amode_x
1509 c_y = registerCode reg_y tmp
1510 r_y = registerName reg_y tmp
1511 sz = primRepToSize pk
1512 -- same optimisation and nagging doubts as previous clause
1513 code__2 | isNilOL c_x
1515 CMP sz (OpAddr am_x) (OpReg r_y)
1519 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1521 CMP sz (OpAddr am_x) (OpReg tmp)
1523 returnNat (CondCode False cond code__2)
1525 -- anything vs anything
1526 condIntCode cond x y
1527 = getRegister x `thenNat` \ register1 ->
1528 getRegister y `thenNat` \ register2 ->
1529 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1530 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1532 code1 = registerCode register1 tmp1
1533 src1 = registerName register1 tmp1
1534 code2 = registerCode register2 tmp2
1535 src2 = registerName register2 tmp2
1536 code__2 = code1 `snocOL`
1537 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1539 CMP L (OpReg src2) (OpReg tmp1)
1541 returnNat (CondCode False cond code__2)
1544 condFltCode cond x y
1545 = getRegister x `thenNat` \ register1 ->
1546 getRegister y `thenNat` \ register2 ->
1547 getNewRegNCG (registerRep register1)
1549 getNewRegNCG (registerRep register2)
1551 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1553 pk1 = registerRep register1
1554 code1 = registerCode register1 tmp1
1555 src1 = registerName register1 tmp1
1557 code2 = registerCode register2 tmp2
1558 src2 = registerName register2 tmp2
1560 code__2 | isAny register1
1561 = code1 `appOL` -- result in tmp1
1563 GCMP (primRepToSize pk1) tmp1 src2
1567 GMOV src1 tmp1 `appOL`
1569 GCMP (primRepToSize pk1) tmp1 src2
1571 {- On the 486, the flags set by FP compare are the unsigned ones!
1572 (This looks like a HACK to me. WDP 96/03)
1574 fix_FP_cond :: Cond -> Cond
1576 fix_FP_cond GE = GEU
1577 fix_FP_cond GTT = GU
1578 fix_FP_cond LTT = LU
1579 fix_FP_cond LE = LEU
1580 fix_FP_cond any = any
1582 returnNat (CondCode True (fix_FP_cond cond) code__2)
1586 #endif {- i386_TARGET_ARCH -}
1587 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1588 #if sparc_TARGET_ARCH
1590 condIntCode cond x (StInt y)
1592 = getRegister x `thenNat` \ register ->
1593 getNewRegNCG IntRep `thenNat` \ tmp ->
1595 code = registerCode register tmp
1596 src1 = registerName register tmp
1597 src2 = ImmInt (fromInteger y)
1598 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1600 returnNat (CondCode False cond code__2)
1602 condIntCode cond x y
1603 = getRegister x `thenNat` \ register1 ->
1604 getRegister y `thenNat` \ register2 ->
1605 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1606 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1608 code1 = registerCode register1 tmp1
1609 src1 = registerName register1 tmp1
1610 code2 = registerCode register2 tmp2
1611 src2 = registerName register2 tmp2
1612 code__2 = code1 `appOL` code2 `snocOL`
1613 SUB False True src1 (RIReg src2) g0
1615 returnNat (CondCode False cond code__2)
1618 condFltCode cond x y
1619 = getRegister x `thenNat` \ register1 ->
1620 getRegister y `thenNat` \ register2 ->
1621 getNewRegNCG (registerRep register1)
1623 getNewRegNCG (registerRep register2)
1625 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1627 promote x = FxTOy F DF x tmp
1629 pk1 = registerRep register1
1630 code1 = registerCode register1 tmp1
1631 src1 = registerName register1 tmp1
1633 pk2 = registerRep register2
1634 code2 = registerCode register2 tmp2
1635 src2 = registerName register2 tmp2
1639 code1 `appOL` code2 `snocOL`
1640 FCMP True (primRepToSize pk1) src1 src2
1641 else if pk1 == FloatRep then
1642 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1643 FCMP True DF tmp src2
1645 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1646 FCMP True DF src1 tmp
1648 returnNat (CondCode True cond code__2)
1650 #endif {- sparc_TARGET_ARCH -}
1653 %************************************************************************
1655 \subsection{Generating assignments}
1657 %************************************************************************
1659 Assignments are really at the heart of the whole code generation
1660 business. Almost all top-level nodes of any real importance are
1661 assignments, which correspond to loads, stores, or register transfers.
1662 If we're really lucky, some of the register transfers will go away,
1663 because we can use the destination register to complete the code
1664 generation for the right hand side. This only fails when the right
1665 hand side is forced into a fixed register (e.g. the result of a call).
1668 assignIntCode, assignFltCode
1669 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1671 #if alpha_TARGET_ARCH
1673 assignIntCode pk (StInd _ dst) src
1674 = getNewRegNCG IntRep `thenNat` \ tmp ->
1675 getAmode dst `thenNat` \ amode ->
1676 getRegister src `thenNat` \ register ->
1678 code1 = amodeCode amode []
1679 dst__2 = amodeAddr amode
1680 code2 = registerCode register tmp []
1681 src__2 = registerName register tmp
1682 sz = primRepToSize pk
1683 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1687 assignIntCode pk dst src
1688 = getRegister dst `thenNat` \ register1 ->
1689 getRegister src `thenNat` \ register2 ->
1691 dst__2 = registerName register1 zeroh
1692 code = registerCode register2 dst__2
1693 src__2 = registerName register2 dst__2
1694 code__2 = if isFixed register2
1695 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1700 #endif {- alpha_TARGET_ARCH -}
1701 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1702 #if i386_TARGET_ARCH
1704 -- Destination of an assignment can only be reg or mem.
1705 -- This is the mem case.
1706 assignIntCode pk (StInd _ dst) src
1707 = getAmode dst `thenNat` \ amode ->
1708 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1709 getNewRegNCG PtrRep `thenNat` \ tmp ->
1711 -- In general, if the address computation for dst may require
1712 -- some insns preceding the addressing mode itself. So there's
1713 -- no guarantee that the code for dst and the code for src won't
1714 -- write the same register. This means either the address or
1715 -- the value needs to be copied into a temporary. We detect the
1716 -- common case where the amode has no code, and elide the copy.
1717 codea = amodeCode amode
1718 dst__a = amodeAddr amode
1720 code | isNilOL codea
1722 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1726 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1728 MOV (primRepToSize pk) opsrc
1729 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1735 -> NatM (InstrBlock,Operand) -- code, operator
1739 = returnNat (nilOL, OpImm imm_op)
1742 imm_op = case imm of Just x -> x
1745 = getRegister op `thenNat` \ register ->
1746 getNewRegNCG (registerRep register)
1748 let code = registerCode register tmp
1749 reg = registerName register tmp
1751 returnNat (code, OpReg reg)
1753 -- Assign; dst is a reg, rhs is mem
1754 assignIntCode pk dst (StInd pks src)
1755 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1756 getAmode src `thenNat` \ amode ->
1757 getRegister dst `thenNat` \ reg_dst ->
1759 c_addr = amodeCode amode
1760 am_addr = amodeAddr amode
1762 c_dst = registerCode reg_dst tmp -- should be empty
1763 r_dst = registerName reg_dst tmp
1764 szs = primRepToSize pks
1765 opc = case szs of L -> MOV L ; B -> MOVZxL B
1767 code | isNilOL c_dst
1769 opc (OpAddr am_addr) (OpReg r_dst)
1771 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1775 -- dst is a reg, but src could be anything
1776 assignIntCode pk dst src
1777 = getRegister dst `thenNat` \ registerd ->
1778 getRegister src `thenNat` \ registers ->
1779 getNewRegNCG IntRep `thenNat` \ tmp ->
1781 r_dst = registerName registerd tmp
1782 c_dst = registerCode registerd tmp -- should be empty
1783 r_src = registerName registers r_dst
1784 c_src = registerCode registers r_dst
1786 code | isNilOL c_dst
1788 MOV L (OpReg r_src) (OpReg r_dst)
1790 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1794 #endif {- i386_TARGET_ARCH -}
1795 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1796 #if sparc_TARGET_ARCH
1798 assignIntCode pk (StInd _ dst) src
1799 = getNewRegNCG IntRep `thenNat` \ tmp ->
1800 getAmode dst `thenNat` \ amode ->
1801 getRegister src `thenNat` \ register ->
1803 code1 = amodeCode amode
1804 dst__2 = amodeAddr amode
1805 code2 = registerCode register tmp
1806 src__2 = registerName register tmp
1807 sz = primRepToSize pk
1808 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1812 assignIntCode pk dst src
1813 = getRegister dst `thenNat` \ register1 ->
1814 getRegister src `thenNat` \ register2 ->
1816 dst__2 = registerName register1 g0
1817 code = registerCode register2 dst__2
1818 src__2 = registerName register2 dst__2
1819 code__2 = if isFixed register2
1820 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1825 #endif {- sparc_TARGET_ARCH -}
1828 % --------------------------------
1829 Floating-point assignments:
1830 % --------------------------------
1832 #if alpha_TARGET_ARCH
1834 assignFltCode pk (StInd _ dst) src
1835 = getNewRegNCG pk `thenNat` \ tmp ->
1836 getAmode dst `thenNat` \ amode ->
1837 getRegister src `thenNat` \ register ->
1839 code1 = amodeCode amode []
1840 dst__2 = amodeAddr amode
1841 code2 = registerCode register tmp []
1842 src__2 = registerName register tmp
1843 sz = primRepToSize pk
1844 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1848 assignFltCode pk dst src
1849 = getRegister dst `thenNat` \ register1 ->
1850 getRegister src `thenNat` \ register2 ->
1852 dst__2 = registerName register1 zeroh
1853 code = registerCode register2 dst__2
1854 src__2 = registerName register2 dst__2
1855 code__2 = if isFixed register2
1856 then code . mkSeqInstr (FMOV src__2 dst__2)
1861 #endif {- alpha_TARGET_ARCH -}
1862 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1863 #if i386_TARGET_ARCH
1866 assignFltCode pk (StInd pk_dst addr) src
1868 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1870 = getRegister src `thenNat` \ reg_src ->
1871 getRegister addr `thenNat` \ reg_addr ->
1872 getNewRegNCG pk `thenNat` \ tmp_src ->
1873 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1874 let r_src = registerName reg_src tmp_src
1875 c_src = registerCode reg_src tmp_src
1876 r_addr = registerName reg_addr tmp_addr
1877 c_addr = registerCode reg_addr tmp_addr
1878 sz = primRepToSize pk
1880 code = c_src `appOL`
1881 -- no need to preserve r_src across the addr computation,
1882 -- since r_src must be a float reg
1883 -- whilst r_addr is an int reg
1886 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1890 -- dst must be a (FP) register
1891 assignFltCode pk dst src
1892 = getRegister dst `thenNat` \ reg_dst ->
1893 getRegister src `thenNat` \ reg_src ->
1894 getNewRegNCG pk `thenNat` \ tmp ->
1896 r_dst = registerName reg_dst tmp
1897 c_dst = registerCode reg_dst tmp -- should be empty
1899 r_src = registerName reg_src r_dst
1900 c_src = registerCode reg_src r_dst
1902 code | isNilOL c_dst
1903 = if isFixed reg_src
1904 then c_src `snocOL` GMOV r_src r_dst
1907 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1913 #endif {- i386_TARGET_ARCH -}
1914 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1915 #if sparc_TARGET_ARCH
1917 assignFltCode pk (StInd _ dst) src
1918 = getNewRegNCG pk `thenNat` \ tmp1 ->
1919 getAmode dst `thenNat` \ amode ->
1920 getRegister src `thenNat` \ register ->
1922 sz = primRepToSize pk
1923 dst__2 = amodeAddr amode
1925 code1 = amodeCode amode
1926 code2 = registerCode register tmp1
1928 src__2 = registerName register tmp1
1929 pk__2 = registerRep register
1930 sz__2 = primRepToSize pk__2
1932 code__2 = code1 `appOL` code2 `appOL`
1934 then unitOL (ST sz src__2 dst__2)
1935 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1939 assignFltCode pk dst src
1940 = getRegister dst `thenNat` \ register1 ->
1941 getRegister src `thenNat` \ register2 ->
1943 pk__2 = registerRep register2
1944 sz__2 = primRepToSize pk__2
1946 getNewRegNCG pk__2 `thenNat` \ tmp ->
1948 sz = primRepToSize pk
1949 dst__2 = registerName register1 g0 -- must be Fixed
1952 reg__2 = if pk /= pk__2 then tmp else dst__2
1954 code = registerCode register2 reg__2
1956 src__2 = registerName register2 reg__2
1960 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1961 else if isFixed register2 then
1962 code `snocOL` FMOV sz src__2 dst__2
1968 #endif {- sparc_TARGET_ARCH -}
1971 %************************************************************************
1973 \subsection{Generating an unconditional branch}
1975 %************************************************************************
1977 We accept two types of targets: an immediate CLabel or a tree that
1978 gets evaluated into a register. Any CLabels which are AsmTemporaries
1979 are assumed to be in the local block of code, close enough for a
1980 branch instruction. Other CLabels are assumed to be far away.
1982 (If applicable) Do not fill the delay slots here; you will confuse the
1986 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
1988 #if alpha_TARGET_ARCH
1990 genJump (StCLbl lbl)
1991 | isAsmTemp lbl = returnInstr (BR target)
1992 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1994 target = ImmCLbl lbl
1997 = getRegister tree `thenNat` \ register ->
1998 getNewRegNCG PtrRep `thenNat` \ tmp ->
2000 dst = registerName register pv
2001 code = registerCode register pv
2002 target = registerName register pv
2004 if isFixed register then
2005 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2007 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2009 #endif {- alpha_TARGET_ARCH -}
2010 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2011 #if i386_TARGET_ARCH
2013 genJump dsts (StInd pk mem)
2014 = getAmode mem `thenNat` \ amode ->
2016 code = amodeCode amode
2017 target = amodeAddr amode
2019 returnNat (code `snocOL` JMP dsts (OpAddr target))
2023 = returnNat (unitOL (JMP dsts (OpImm target)))
2026 = getRegister tree `thenNat` \ register ->
2027 getNewRegNCG PtrRep `thenNat` \ tmp ->
2029 code = registerCode register tmp
2030 target = registerName register tmp
2032 returnNat (code `snocOL` JMP dsts (OpReg target))
2035 target = case imm of Just x -> x
2037 #endif {- i386_TARGET_ARCH -}
2038 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2039 #if sparc_TARGET_ARCH
2041 genJump dsts (StCLbl lbl)
2042 | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2043 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2044 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2046 target = ImmCLbl lbl
2049 = getRegister tree `thenNat` \ register ->
2050 getNewRegNCG PtrRep `thenNat` \ tmp ->
2052 code = registerCode register tmp
2053 target = registerName register tmp
2055 returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2057 #endif {- sparc_TARGET_ARCH -}
2060 %************************************************************************
2062 \subsection{Conditional jumps}
2064 %************************************************************************
2066 Conditional jumps are always to local labels, so we can use branch
2067 instructions. We peek at the arguments to decide what kind of
2070 ALPHA: For comparisons with 0, we're laughing, because we can just do
2071 the desired conditional branch.
2073 I386: First, we have to ensure that the condition
2074 codes are set according to the supplied comparison operation.
2076 SPARC: First, we have to ensure that the condition codes are set
2077 according to the supplied comparison operation. We generate slightly
2078 different code for floating point comparisons, because a floating
2079 point operation cannot directly precede a @BF@. We assume the worst
2080 and fill that slot with a @NOP@.
2082 SPARC: Do not fill the delay slots here; you will confuse the register
2087 :: CLabel -- the branch target
2088 -> StixTree -- the condition on which to branch
2091 #if alpha_TARGET_ARCH
2093 genCondJump lbl (StPrim op [x, StInt 0])
2094 = getRegister x `thenNat` \ register ->
2095 getNewRegNCG (registerRep register)
2098 code = registerCode register tmp
2099 value = registerName register tmp
2100 pk = registerRep register
2101 target = ImmCLbl lbl
2103 returnSeq code [BI (cmpOp op) value target]
2105 cmpOp CharGtOp = GTT
2107 cmpOp CharEqOp = EQQ
2109 cmpOp CharLtOp = LTT
2118 cmpOp WordGeOp = ALWAYS
2119 cmpOp WordEqOp = EQQ
2121 cmpOp WordLtOp = NEVER
2122 cmpOp WordLeOp = EQQ
2124 cmpOp AddrGeOp = ALWAYS
2125 cmpOp AddrEqOp = EQQ
2127 cmpOp AddrLtOp = NEVER
2128 cmpOp AddrLeOp = EQQ
2130 genCondJump lbl (StPrim op [x, StDouble 0.0])
2131 = getRegister x `thenNat` \ register ->
2132 getNewRegNCG (registerRep register)
2135 code = registerCode register tmp
2136 value = registerName register tmp
2137 pk = registerRep register
2138 target = ImmCLbl lbl
2140 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2142 cmpOp FloatGtOp = GTT
2143 cmpOp FloatGeOp = GE
2144 cmpOp FloatEqOp = EQQ
2145 cmpOp FloatNeOp = NE
2146 cmpOp FloatLtOp = LTT
2147 cmpOp FloatLeOp = LE
2148 cmpOp DoubleGtOp = GTT
2149 cmpOp DoubleGeOp = GE
2150 cmpOp DoubleEqOp = EQQ
2151 cmpOp DoubleNeOp = NE
2152 cmpOp DoubleLtOp = LTT
2153 cmpOp DoubleLeOp = LE
2155 genCondJump lbl (StPrim op [x, y])
2157 = trivialFCode pr instr x y `thenNat` \ register ->
2158 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2160 code = registerCode register tmp
2161 result = registerName register tmp
2162 target = ImmCLbl lbl
2164 returnNat (code . mkSeqInstr (BF cond result target))
2166 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2168 fltCmpOp op = case op of
2182 (instr, cond) = case op of
2183 FloatGtOp -> (FCMP TF LE, EQQ)
2184 FloatGeOp -> (FCMP TF LTT, EQQ)
2185 FloatEqOp -> (FCMP TF EQQ, NE)
2186 FloatNeOp -> (FCMP TF EQQ, EQQ)
2187 FloatLtOp -> (FCMP TF LTT, NE)
2188 FloatLeOp -> (FCMP TF LE, NE)
2189 DoubleGtOp -> (FCMP TF LE, EQQ)
2190 DoubleGeOp -> (FCMP TF LTT, EQQ)
2191 DoubleEqOp -> (FCMP TF EQQ, NE)
2192 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2193 DoubleLtOp -> (FCMP TF LTT, NE)
2194 DoubleLeOp -> (FCMP TF LE, NE)
2196 genCondJump lbl (StPrim op [x, y])
2197 = trivialCode instr x y `thenNat` \ register ->
2198 getNewRegNCG IntRep `thenNat` \ tmp ->
2200 code = registerCode register tmp
2201 result = registerName register tmp
2202 target = ImmCLbl lbl
2204 returnNat (code . mkSeqInstr (BI cond result target))
2206 (instr, cond) = case op of
2207 CharGtOp -> (CMP LE, EQQ)
2208 CharGeOp -> (CMP LTT, EQQ)
2209 CharEqOp -> (CMP EQQ, NE)
2210 CharNeOp -> (CMP EQQ, EQQ)
2211 CharLtOp -> (CMP LTT, NE)
2212 CharLeOp -> (CMP LE, NE)
2213 IntGtOp -> (CMP LE, EQQ)
2214 IntGeOp -> (CMP LTT, EQQ)
2215 IntEqOp -> (CMP EQQ, NE)
2216 IntNeOp -> (CMP EQQ, EQQ)
2217 IntLtOp -> (CMP LTT, NE)
2218 IntLeOp -> (CMP LE, NE)
2219 WordGtOp -> (CMP ULE, EQQ)
2220 WordGeOp -> (CMP ULT, EQQ)
2221 WordEqOp -> (CMP EQQ, NE)
2222 WordNeOp -> (CMP EQQ, EQQ)
2223 WordLtOp -> (CMP ULT, NE)
2224 WordLeOp -> (CMP ULE, NE)
2225 AddrGtOp -> (CMP ULE, EQQ)
2226 AddrGeOp -> (CMP ULT, EQQ)
2227 AddrEqOp -> (CMP EQQ, NE)
2228 AddrNeOp -> (CMP EQQ, EQQ)
2229 AddrLtOp -> (CMP ULT, NE)
2230 AddrLeOp -> (CMP ULE, NE)
2232 #endif {- alpha_TARGET_ARCH -}
2233 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2234 #if i386_TARGET_ARCH
2236 genCondJump lbl bool
2237 = getCondCode bool `thenNat` \ condition ->
2239 code = condCode condition
2240 cond = condName condition
2241 target = ImmCLbl lbl
2243 returnNat (code `snocOL` JXX cond lbl)
2245 #endif {- i386_TARGET_ARCH -}
2246 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2247 #if sparc_TARGET_ARCH
2249 genCondJump lbl bool
2250 = getCondCode bool `thenNat` \ condition ->
2252 code = condCode condition
2253 cond = condName condition
2254 target = ImmCLbl lbl
2259 if condFloat condition
2260 then [NOP, BF cond False target, NOP]
2261 else [BI cond False target, NOP]
2265 #endif {- sparc_TARGET_ARCH -}
2268 %************************************************************************
2270 \subsection{Generating C calls}
2272 %************************************************************************
2274 Now the biggest nightmare---calls. Most of the nastiness is buried in
2275 @get_arg@, which moves the arguments to the correct registers/stack
2276 locations. Apart from that, the code is easy.
2278 (If applicable) Do not fill the delay slots here; you will confuse the
2283 :: FAST_STRING -- function to call
2285 -> PrimRep -- type of the result
2286 -> [StixTree] -- arguments (of mixed type)
2289 #if alpha_TARGET_ARCH
2291 genCCall fn cconv kind args
2292 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2293 `thenNat` \ ((unused,_), argCode) ->
2295 nRegs = length allArgRegs - length unused
2296 code = asmSeqThen (map ($ []) argCode)
2299 LDA pv (AddrImm (ImmLab (ptext fn))),
2300 JSR ra (AddrReg pv) nRegs,
2301 LDGP gp (AddrReg ra)]
2303 ------------------------
2304 {- Try to get a value into a specific register (or registers) for
2305 a call. The first 6 arguments go into the appropriate
2306 argument register (separate registers for integer and floating
2307 point arguments, but used in lock-step), and the remaining
2308 arguments are dumped to the stack, beginning at 0(sp). Our
2309 first argument is a pair of the list of remaining argument
2310 registers to be assigned for this call and the next stack
2311 offset to use for overflowing arguments. This way,
2312 @get_Arg@ can be applied to all of a call's arguments using
2316 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2317 -> StixTree -- Current argument
2318 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2320 -- We have to use up all of our argument registers first...
2322 get_arg ((iDst,fDst):dsts, offset) arg
2323 = getRegister arg `thenNat` \ register ->
2325 reg = if isFloatingRep pk then fDst else iDst
2326 code = registerCode register reg
2327 src = registerName register reg
2328 pk = registerRep register
2331 if isFloatingRep pk then
2332 ((dsts, offset), if isFixed register then
2333 code . mkSeqInstr (FMOV src fDst)
2336 ((dsts, offset), if isFixed register then
2337 code . mkSeqInstr (OR src (RIReg src) iDst)
2340 -- Once we have run out of argument registers, we move to the
2343 get_arg ([], offset) arg
2344 = getRegister arg `thenNat` \ register ->
2345 getNewRegNCG (registerRep register)
2348 code = registerCode register tmp
2349 src = registerName register tmp
2350 pk = registerRep register
2351 sz = primRepToSize pk
2353 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2355 #endif {- alpha_TARGET_ARCH -}
2356 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2357 #if i386_TARGET_ARCH
2359 genCCall fn cconv kind [StInt i]
2360 | fn == SLIT ("PerformGC_wrapper")
2362 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2363 CALL (ImmLit (ptext (if underscorePrefix
2364 then (SLIT ("_PerformGC_wrapper"))
2365 else (SLIT ("PerformGC_wrapper")))))
2371 genCCall fn cconv kind args
2372 = mapNat get_call_arg
2373 (reverse args) `thenNat` \ sizes_n_codes ->
2374 getDeltaNat `thenNat` \ delta ->
2375 let (sizes, codes) = unzip sizes_n_codes
2376 tot_arg_size = sum sizes
2377 code2 = concatOL codes
2380 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2381 DELTA (delta + tot_arg_size)
2384 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2385 returnNat (code2 `appOL` call)
2388 -- function names that begin with '.' are assumed to be special
2389 -- internally generated names like '.mul,' which don't get an
2390 -- underscore prefix
2391 -- ToDo:needed (WDP 96/03) ???
2392 fn__2 = case (_HEAD_ fn) of
2393 '.' -> ImmLit (ptext fn)
2394 _ -> ImmLab False (ptext fn)
2401 get_call_arg :: StixTree{-current argument-}
2402 -> NatM (Int, InstrBlock) -- argsz, code
2405 = get_op arg `thenNat` \ (code, reg, sz) ->
2406 getDeltaNat `thenNat` \ delta ->
2407 arg_size sz `bind` \ size ->
2408 setDeltaNat (delta-size) `thenNat` \ _ ->
2409 if (case sz of DF -> True; F -> True; _ -> False)
2410 then returnNat (size,
2412 toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2414 GST sz reg (AddrBaseIndex (Just esp)
2418 else returnNat (size,
2420 PUSH L (OpReg reg) `snocOL`
2426 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2429 = getRegister op `thenNat` \ register ->
2430 getNewRegNCG (registerRep register)
2433 code = registerCode register tmp
2434 reg = registerName register tmp
2435 pk = registerRep register
2436 sz = primRepToSize pk
2438 returnNat (code, reg, sz)
2440 #endif {- i386_TARGET_ARCH -}
2441 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2442 #if sparc_TARGET_ARCH
2444 The SPARC calling convention is an absolute
2445 nightmare. The first 6x32 bits of arguments are mapped into
2446 %o0 through %o5, and the remaining arguments are dumped to the
2447 stack, beginning at [%sp+92]. (Note that %o6 == %sp.)
2449 If we have to put args on the stack, move %o6==%sp down by
2450 the number of words to go on the stack, to ensure there's enough space.
2452 According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2453 16 words above the stack pointer is a word for the address of
2454 a structure return value. I use this as a temporary location
2455 for moving values from float to int regs. Certainly it isn't
2456 safe to put anything in the 16 words starting at %sp, since
2457 this area can get trashed at any time due to window overflows
2458 caused by signal handlers.
2460 A final complication (if the above isn't enough) is that
2461 we can't blithely calculate the arguments one by one into
2462 %o0 .. %o5. Consider the following nested calls:
2466 Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately
2467 the inner call will itself use %o0, which trashes the value put there
2468 in preparation for the outer call. Upshot: we need to calculate the
2469 args into temporary regs, and move those to arg regs or onto the
2470 stack only immediately prior to the call proper. Sigh.
2473 genCCall fn cconv kind args
2474 = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2475 let (argcodes, vregss) = unzip argcode_and_vregs
2476 argcode = concatOL argcodes
2477 vregs = concat vregss
2478 n_argRegs = length allArgRegs
2479 n_argRegs_used = min (length vregs) n_argRegs
2480 (move_sp_down, move_sp_up)
2481 = let nn = length vregs - n_argRegs
2482 + 1 -- (for the road)
2485 else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2487 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2489 = unitOL (CALL fn__2 n_argRegs_used False)
2491 returnNat (argcode `appOL`
2492 move_sp_down `appOL`
2493 transfer_code `appOL`
2498 -- function names that begin with '.' are assumed to be special
2499 -- internally generated names like '.mul,' which don't get an
2500 -- underscore prefix
2501 -- ToDo:needed (WDP 96/03) ???
2502 fn__2 = case (_HEAD_ fn) of
2503 '.' -> ImmLit (ptext fn)
2504 _ -> ImmLab False (ptext fn)
2506 -- move args from the integer vregs into which they have been
2507 -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2508 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2510 move_final [] _ offset -- all args done
2513 move_final (v:vs) [] offset -- out of aregs; move to stack
2514 = ST W v (spRel offset)
2515 : move_final vs [] (offset+1)
2517 move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2518 = OR False g0 (RIReg v) a
2519 : move_final vs az offset
2521 -- generate code to calculate an argument, and move it into one
2522 -- or two integer vregs.
2523 arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2524 arg_to_int_vregs arg
2525 = getRegister arg `thenNat` \ register ->
2526 getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2527 let code = registerCode register tmp
2528 src = registerName register tmp
2529 pk = registerRep register
2531 -- the value is in src. Get it into 1 or 2 int vregs.
2534 getNewRegNCG WordRep `thenNat` \ v1 ->
2535 getNewRegNCG WordRep `thenNat` \ v2 ->
2538 FMOV DF src f0 `snocOL`
2539 ST F f0 (spRel 16) `snocOL`
2540 LD W (spRel 16) v1 `snocOL`
2541 ST F (fPair f0) (spRel 16) `snocOL`
2547 getNewRegNCG WordRep `thenNat` \ v1 ->
2550 ST F src (spRel 16) `snocOL`
2556 getNewRegNCG WordRep `thenNat` \ v1 ->
2558 code `snocOL` OR False g0 (RIReg src) v1
2562 #endif {- sparc_TARGET_ARCH -}
2565 %************************************************************************
2567 \subsection{Support bits}
2569 %************************************************************************
2571 %************************************************************************
2573 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2575 %************************************************************************
2577 Turn those condition codes into integers now (when they appear on
2578 the right hand side of an assignment).
2580 (If applicable) Do not fill the delay slots here; you will confuse the
2584 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2586 #if alpha_TARGET_ARCH
2587 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2588 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2589 #endif {- alpha_TARGET_ARCH -}
2591 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2592 #if i386_TARGET_ARCH
2595 = condIntCode cond x y `thenNat` \ condition ->
2596 getNewRegNCG IntRep `thenNat` \ tmp ->
2598 code = condCode condition
2599 cond = condName condition
2600 code__2 dst = code `appOL` toOL [
2601 SETCC cond (OpReg tmp),
2602 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2603 MOV L (OpReg tmp) (OpReg dst)]
2605 returnNat (Any IntRep code__2)
2608 = getNatLabelNCG `thenNat` \ lbl1 ->
2609 getNatLabelNCG `thenNat` \ lbl2 ->
2610 condFltCode cond x y `thenNat` \ condition ->
2612 code = condCode condition
2613 cond = condName condition
2614 code__2 dst = code `appOL` toOL [
2616 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2619 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2622 returnNat (Any IntRep code__2)
2624 #endif {- i386_TARGET_ARCH -}
2625 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2626 #if sparc_TARGET_ARCH
2628 condIntReg EQQ x (StInt 0)
2629 = getRegister x `thenNat` \ register ->
2630 getNewRegNCG IntRep `thenNat` \ tmp ->
2632 code = registerCode register tmp
2633 src = registerName register tmp
2634 code__2 dst = code `appOL` toOL [
2635 SUB False True g0 (RIReg src) g0,
2636 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2638 returnNat (Any IntRep code__2)
2641 = getRegister x `thenNat` \ register1 ->
2642 getRegister y `thenNat` \ register2 ->
2643 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2644 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2646 code1 = registerCode register1 tmp1
2647 src1 = registerName register1 tmp1
2648 code2 = registerCode register2 tmp2
2649 src2 = registerName register2 tmp2
2650 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2651 XOR False src1 (RIReg src2) dst,
2652 SUB False True g0 (RIReg dst) g0,
2653 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2655 returnNat (Any IntRep code__2)
2657 condIntReg NE x (StInt 0)
2658 = getRegister x `thenNat` \ register ->
2659 getNewRegNCG IntRep `thenNat` \ tmp ->
2661 code = registerCode register tmp
2662 src = registerName register tmp
2663 code__2 dst = code `appOL` toOL [
2664 SUB False True g0 (RIReg src) g0,
2665 ADD True False g0 (RIImm (ImmInt 0)) dst]
2667 returnNat (Any IntRep code__2)
2670 = getRegister x `thenNat` \ register1 ->
2671 getRegister y `thenNat` \ register2 ->
2672 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2673 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2675 code1 = registerCode register1 tmp1
2676 src1 = registerName register1 tmp1
2677 code2 = registerCode register2 tmp2
2678 src2 = registerName register2 tmp2
2679 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2680 XOR False src1 (RIReg src2) dst,
2681 SUB False True g0 (RIReg dst) g0,
2682 ADD True False g0 (RIImm (ImmInt 0)) dst]
2684 returnNat (Any IntRep code__2)
2687 = getNatLabelNCG `thenNat` \ lbl1 ->
2688 getNatLabelNCG `thenNat` \ lbl2 ->
2689 condIntCode cond x y `thenNat` \ condition ->
2691 code = condCode condition
2692 cond = condName condition
2693 code__2 dst = code `appOL` toOL [
2694 BI cond False (ImmCLbl lbl1), NOP,
2695 OR False g0 (RIImm (ImmInt 0)) dst,
2696 BI ALWAYS False (ImmCLbl lbl2), NOP,
2698 OR False g0 (RIImm (ImmInt 1)) dst,
2701 returnNat (Any IntRep code__2)
2704 = getNatLabelNCG `thenNat` \ lbl1 ->
2705 getNatLabelNCG `thenNat` \ lbl2 ->
2706 condFltCode cond x y `thenNat` \ condition ->
2708 code = condCode condition
2709 cond = condName condition
2710 code__2 dst = code `appOL` toOL [
2712 BF cond False (ImmCLbl lbl1), NOP,
2713 OR False g0 (RIImm (ImmInt 0)) dst,
2714 BI ALWAYS False (ImmCLbl lbl2), NOP,
2716 OR False g0 (RIImm (ImmInt 1)) dst,
2719 returnNat (Any IntRep code__2)
2721 #endif {- sparc_TARGET_ARCH -}
2724 %************************************************************************
2726 \subsubsection{@trivial*Code@: deal with trivial instructions}
2728 %************************************************************************
2730 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2731 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2732 for constants on the right hand side, because that's where the generic
2733 optimizer will have put them.
2735 Similarly, for unary instructions, we don't have to worry about
2736 matching an StInt as the argument, because genericOpt will already
2737 have handled the constant-folding.
2741 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2742 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2743 -> Maybe (Operand -> Operand -> Instr)
2744 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2746 -> StixTree -> StixTree -- the two arguments
2751 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2752 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2753 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2755 -> StixTree -> StixTree -- the two arguments
2759 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2760 ,IF_ARCH_i386 ((Operand -> Instr)
2761 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2763 -> StixTree -- the one argument
2768 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2769 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2770 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2772 -> StixTree -- the one argument
2775 #if alpha_TARGET_ARCH
2777 trivialCode instr x (StInt y)
2779 = getRegister x `thenNat` \ register ->
2780 getNewRegNCG IntRep `thenNat` \ tmp ->
2782 code = registerCode register tmp
2783 src1 = registerName register tmp
2784 src2 = ImmInt (fromInteger y)
2785 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2787 returnNat (Any IntRep code__2)
2789 trivialCode instr x y
2790 = getRegister x `thenNat` \ register1 ->
2791 getRegister y `thenNat` \ register2 ->
2792 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2793 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2795 code1 = registerCode register1 tmp1 []
2796 src1 = registerName register1 tmp1
2797 code2 = registerCode register2 tmp2 []
2798 src2 = registerName register2 tmp2
2799 code__2 dst = asmSeqThen [code1, code2] .
2800 mkSeqInstr (instr src1 (RIReg src2) dst)
2802 returnNat (Any IntRep code__2)
2805 trivialUCode instr x
2806 = getRegister x `thenNat` \ register ->
2807 getNewRegNCG IntRep `thenNat` \ tmp ->
2809 code = registerCode register tmp
2810 src = registerName register tmp
2811 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2813 returnNat (Any IntRep code__2)
2816 trivialFCode _ instr x y
2817 = getRegister x `thenNat` \ register1 ->
2818 getRegister y `thenNat` \ register2 ->
2819 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2820 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2822 code1 = registerCode register1 tmp1
2823 src1 = registerName register1 tmp1
2825 code2 = registerCode register2 tmp2
2826 src2 = registerName register2 tmp2
2828 code__2 dst = asmSeqThen [code1 [], code2 []] .
2829 mkSeqInstr (instr src1 src2 dst)
2831 returnNat (Any DoubleRep code__2)
2833 trivialUFCode _ instr x
2834 = getRegister x `thenNat` \ register ->
2835 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2837 code = registerCode register tmp
2838 src = registerName register tmp
2839 code__2 dst = code . mkSeqInstr (instr src dst)
2841 returnNat (Any DoubleRep code__2)
2843 #endif {- alpha_TARGET_ARCH -}
2844 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2845 #if i386_TARGET_ARCH
2847 The Rules of the Game are:
2849 * You cannot assume anything about the destination register dst;
2850 it may be anything, including a fixed reg.
2852 * You may compute an operand into a fixed reg, but you may not
2853 subsequently change the contents of that fixed reg. If you
2854 want to do so, first copy the value either to a temporary
2855 or into dst. You are free to modify dst even if it happens
2856 to be a fixed reg -- that's not your problem.
2858 * You cannot assume that a fixed reg will stay live over an
2859 arbitrary computation. The same applies to the dst reg.
2861 * Temporary regs obtained from getNewRegNCG are distinct from
2862 each other and from all other regs, and stay live over
2863 arbitrary computations.
2867 trivialCode instr maybe_revinstr a b
2870 = getRegister a `thenNat` \ rega ->
2873 then registerCode rega dst `bind` \ code_a ->
2875 instr (OpImm imm_b) (OpReg dst)
2876 else registerCodeF rega `bind` \ code_a ->
2877 registerNameF rega `bind` \ r_a ->
2879 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2880 instr (OpImm imm_b) (OpReg dst)
2882 returnNat (Any IntRep mkcode)
2885 = getRegister b `thenNat` \ regb ->
2886 getNewRegNCG IntRep `thenNat` \ tmp ->
2887 let revinstr_avail = maybeToBool maybe_revinstr
2888 revinstr = case maybe_revinstr of Just ri -> ri
2892 then registerCode regb dst `bind` \ code_b ->
2894 revinstr (OpImm imm_a) (OpReg dst)
2895 else registerCodeF regb `bind` \ code_b ->
2896 registerNameF regb `bind` \ r_b ->
2898 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2899 revinstr (OpImm imm_a) (OpReg dst)
2903 then registerCode regb tmp `bind` \ code_b ->
2905 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2906 instr (OpReg tmp) (OpReg dst)
2907 else registerCodeF regb `bind` \ code_b ->
2908 registerNameF regb `bind` \ r_b ->
2910 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2911 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2912 instr (OpReg tmp) (OpReg dst)
2914 returnNat (Any IntRep mkcode)
2917 = getRegister a `thenNat` \ rega ->
2918 getRegister b `thenNat` \ regb ->
2919 getNewRegNCG IntRep `thenNat` \ tmp ->
2921 = case (isAny rega, isAny regb) of
2923 -> registerCode regb tmp `bind` \ code_b ->
2924 registerCode rega dst `bind` \ code_a ->
2927 instr (OpReg tmp) (OpReg dst)
2929 -> registerCode rega tmp `bind` \ code_a ->
2930 registerCodeF regb `bind` \ code_b ->
2931 registerNameF regb `bind` \ r_b ->
2934 instr (OpReg r_b) (OpReg tmp) `snocOL`
2935 MOV L (OpReg tmp) (OpReg dst)
2937 -> registerCode regb tmp `bind` \ code_b ->
2938 registerCodeF rega `bind` \ code_a ->
2939 registerNameF rega `bind` \ r_a ->
2942 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2943 instr (OpReg tmp) (OpReg dst)
2945 -> registerCodeF rega `bind` \ code_a ->
2946 registerNameF rega `bind` \ r_a ->
2947 registerCodeF regb `bind` \ code_b ->
2948 registerNameF regb `bind` \ r_b ->
2950 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2952 instr (OpReg r_b) (OpReg tmp) `snocOL`
2953 MOV L (OpReg tmp) (OpReg dst)
2955 returnNat (Any IntRep mkcode)
2958 maybe_imm_a = maybeImm a
2959 is_imm_a = maybeToBool maybe_imm_a
2960 imm_a = case maybe_imm_a of Just imm -> imm
2962 maybe_imm_b = maybeImm b
2963 is_imm_b = maybeToBool maybe_imm_b
2964 imm_b = case maybe_imm_b of Just imm -> imm
2968 trivialUCode instr x
2969 = getRegister x `thenNat` \ register ->
2971 code__2 dst = let code = registerCode register dst
2972 src = registerName register dst
2974 if isFixed register && dst /= src
2975 then toOL [MOV L (OpReg src) (OpReg dst),
2977 else unitOL (instr (OpReg src))
2979 returnNat (Any IntRep code__2)
2982 trivialFCode pk instr x y
2983 = getRegister x `thenNat` \ register1 ->
2984 getRegister y `thenNat` \ register2 ->
2985 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2986 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2988 code1 = registerCode register1 tmp1
2989 src1 = registerName register1 tmp1
2991 code2 = registerCode register2 tmp2
2992 src2 = registerName register2 tmp2
2995 -- treat the common case specially: both operands in
2997 | isAny register1 && isAny register2
3000 instr (primRepToSize pk) src1 src2 dst
3002 -- be paranoid (and inefficient)
3004 = code1 `snocOL` GMOV src1 tmp1 `appOL`
3006 instr (primRepToSize pk) tmp1 src2 dst
3008 returnNat (Any pk code__2)
3012 trivialUFCode pk instr x
3013 = getRegister x `thenNat` \ register ->
3014 getNewRegNCG pk `thenNat` \ tmp ->
3016 code = registerCode register tmp
3017 src = registerName register tmp
3018 code__2 dst = code `snocOL` instr src dst
3020 returnNat (Any pk code__2)
3022 #endif {- i386_TARGET_ARCH -}
3023 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3024 #if sparc_TARGET_ARCH
3026 trivialCode instr x (StInt y)
3028 = getRegister x `thenNat` \ register ->
3029 getNewRegNCG IntRep `thenNat` \ tmp ->
3031 code = registerCode register tmp
3032 src1 = registerName register tmp
3033 src2 = ImmInt (fromInteger y)
3034 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3036 returnNat (Any IntRep code__2)
3038 trivialCode instr x y
3039 = getRegister x `thenNat` \ register1 ->
3040 getRegister y `thenNat` \ register2 ->
3041 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3042 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3044 code1 = registerCode register1 tmp1
3045 src1 = registerName register1 tmp1
3046 code2 = registerCode register2 tmp2
3047 src2 = registerName register2 tmp2
3048 code__2 dst = code1 `appOL` code2 `snocOL`
3049 instr src1 (RIReg src2) dst
3051 returnNat (Any IntRep code__2)
3054 trivialFCode pk instr x y
3055 = getRegister x `thenNat` \ register1 ->
3056 getRegister y `thenNat` \ register2 ->
3057 getNewRegNCG (registerRep register1)
3059 getNewRegNCG (registerRep register2)
3061 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3063 promote x = FxTOy F DF x tmp
3065 pk1 = registerRep register1
3066 code1 = registerCode register1 tmp1
3067 src1 = registerName register1 tmp1
3069 pk2 = registerRep register2
3070 code2 = registerCode register2 tmp2
3071 src2 = registerName register2 tmp2
3075 code1 `appOL` code2 `snocOL`
3076 instr (primRepToSize pk) src1 src2 dst
3077 else if pk1 == FloatRep then
3078 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3079 instr DF tmp src2 dst
3081 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3082 instr DF src1 tmp dst
3084 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3087 trivialUCode instr x
3088 = getRegister x `thenNat` \ register ->
3089 getNewRegNCG IntRep `thenNat` \ tmp ->
3091 code = registerCode register tmp
3092 src = registerName register tmp
3093 code__2 dst = code `snocOL` instr (RIReg src) dst
3095 returnNat (Any IntRep code__2)
3098 trivialUFCode pk instr x
3099 = getRegister x `thenNat` \ register ->
3100 getNewRegNCG pk `thenNat` \ tmp ->
3102 code = registerCode register tmp
3103 src = registerName register tmp
3104 code__2 dst = code `snocOL` instr src dst
3106 returnNat (Any pk code__2)
3108 #endif {- sparc_TARGET_ARCH -}
3111 %************************************************************************
3113 \subsubsection{Coercing to/from integer/floating-point...}
3115 %************************************************************************
3117 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3118 to be generated. Here we just change the type on the Register passed
3119 on up. The code is machine-independent.
3121 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3122 conversions. We have to store temporaries in memory to move
3123 between the integer and the floating point register sets.
3126 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3127 coerceFltCode :: StixTree -> NatM Register
3129 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3130 coerceFP2Int :: StixTree -> NatM Register
3133 = getRegister x `thenNat` \ register ->
3136 Fixed _ reg code -> Fixed pk reg code
3137 Any _ code -> Any pk code
3142 = getRegister x `thenNat` \ register ->
3145 Fixed _ reg code -> Fixed DoubleRep reg code
3146 Any _ code -> Any DoubleRep code
3151 #if alpha_TARGET_ARCH
3154 = getRegister x `thenNat` \ register ->
3155 getNewRegNCG IntRep `thenNat` \ reg ->
3157 code = registerCode register reg
3158 src = registerName register reg
3160 code__2 dst = code . mkSeqInstrs [
3162 LD TF dst (spRel 0),
3165 returnNat (Any DoubleRep code__2)
3169 = getRegister x `thenNat` \ register ->
3170 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3172 code = registerCode register tmp
3173 src = registerName register tmp
3175 code__2 dst = code . mkSeqInstrs [
3177 ST TF tmp (spRel 0),
3180 returnNat (Any IntRep code__2)
3182 #endif {- alpha_TARGET_ARCH -}
3183 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3184 #if i386_TARGET_ARCH
3187 = getRegister x `thenNat` \ register ->
3188 getNewRegNCG IntRep `thenNat` \ reg ->
3190 code = registerCode register reg
3191 src = registerName register reg
3192 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3193 code__2 dst = code `snocOL` opc src dst
3195 returnNat (Any pk code__2)
3199 = getRegister x `thenNat` \ register ->
3200 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3202 code = registerCode register tmp
3203 src = registerName register tmp
3204 pk = registerRep register
3206 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3207 code__2 dst = code `snocOL` opc src dst
3209 returnNat (Any IntRep code__2)
3211 #endif {- i386_TARGET_ARCH -}
3212 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3213 #if sparc_TARGET_ARCH
3216 = getRegister x `thenNat` \ register ->
3217 getNewRegNCG IntRep `thenNat` \ reg ->
3219 code = registerCode register reg
3220 src = registerName register reg
3222 code__2 dst = code `appOL` toOL [
3223 ST W src (spRel (-2)),
3224 LD W (spRel (-2)) dst,
3225 FxTOy W (primRepToSize pk) dst dst]
3227 returnNat (Any pk code__2)
3231 = getRegister x `thenNat` \ register ->
3232 getNewRegNCG IntRep `thenNat` \ reg ->
3233 getNewRegNCG FloatRep `thenNat` \ tmp ->
3235 code = registerCode register reg
3236 src = registerName register reg
3237 pk = registerRep register
3239 code__2 dst = code `appOL` toOL [
3240 FxTOy (primRepToSize pk) W src tmp,
3241 ST W tmp (spRel (-2)),
3242 LD W (spRel (-2)) dst]
3244 returnNat (Any IntRep code__2)
3246 #endif {- sparc_TARGET_ARCH -}
3249 %************************************************************************
3251 \subsubsection{Coercing integer to @Char@...}
3253 %************************************************************************
3255 Integer to character conversion.
3258 chrCode :: StixTree -> NatM Register
3260 #if alpha_TARGET_ARCH
3262 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3263 -- It should coerce a 64-bit value to a 32-bit value.
3266 = getRegister x `thenNat` \ register ->
3267 getNewRegNCG IntRep `thenNat` \ reg ->
3269 code = registerCode register reg
3270 src = registerName register reg
3271 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3273 returnNat (Any IntRep code__2)
3275 #endif {- alpha_TARGET_ARCH -}
3276 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3277 #if i386_TARGET_ARCH
3280 = getRegister x `thenNat` \ register ->
3283 Fixed _ reg code -> Fixed IntRep reg code
3284 Any _ code -> Any IntRep code
3287 #endif {- i386_TARGET_ARCH -}
3288 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3289 #if sparc_TARGET_ARCH
3292 = getRegister x `thenNat` \ register ->
3295 Fixed _ reg code -> Fixed IntRep reg code
3296 Any _ code -> Any IntRep code
3299 #endif {- sparc_TARGET_ARCH -}