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 AbsCSyn ( MagicId )
22 import AbsCUtils ( magicIdPrimRep )
23 import CallConv ( CallConv )
24 import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
25 import Maybes ( maybeToBool, expectJust )
26 import PrimRep ( isFloatingRep, PrimRep(..) )
27 import PrimOp ( PrimOp(..) )
28 import CallConv ( cCallConv )
29 import Stix ( getNatLabelNCG, StixTree(..),
30 StixReg(..), CodeSegment(..),
31 pprStixTrees, ppStixReg,
32 NatM, thenNat, returnNat, mapNat, mapAndUnzipNat,
33 getDeltaNat, setDeltaNat
39 @InstrBlock@s are the insn sequences generated by the insn selectors.
40 They are really trees of insns to facilitate fast appending, where a
41 left-to-right traversal (pre-order?) yields the insns in the correct
46 type InstrBlock = OrdList Instr
53 Code extractor for an entire stix tree---stix statement level.
56 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
58 stmt2Instrs stmt = case stmt of
59 StComment s -> returnNat (unitOL (COMMENT s))
60 StSegment seg -> returnNat (unitOL (SEGMENT seg))
62 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
64 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
66 StLabel lab -> returnNat (unitOL (LABEL lab))
68 StJump arg -> genJump arg
69 StCondJump lab arg -> genCondJump lab arg
70 StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
73 | isFloatingRep pk -> assignFltCode pk dst src
74 | otherwise -> assignIntCode pk dst src
77 -- When falling through on the Alpha, we still have to load pv
78 -- with the address of the next routine, so that it can load gp.
79 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
83 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
84 returnNat (DATA (primRepToSize kind) imms
85 `consOL` concatOL codes)
87 getData :: StixTree -> NatM (InstrBlock, Imm)
89 getData (StInt i) = returnNat (nilOL, ImmInteger i)
90 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
91 getData (StLitLbl s) = returnNat (nilOL, ImmLab s)
92 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
93 getData (StString s) =
94 getNatLabelNCG `thenNat` \ lbl ->
95 returnNat (toOL [LABEL lbl,
96 ASCII True (_UNPK_ s)],
98 -- the linker can handle simple arithmetic...
99 getData (StIndex rep (StCLbl lbl) (StInt off)) =
101 ImmIndex lbl (fromInteger (off * sizeOf rep)))
104 %************************************************************************
106 \subsection{General things for putting together code sequences}
108 %************************************************************************
111 mangleIndexTree :: StixTree -> StixTree
113 mangleIndexTree (StIndex pk base (StInt i))
114 = StPrim IntAddOp [base, off]
116 off = StInt (i * sizeOf pk)
118 mangleIndexTree (StIndex pk base off)
122 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
123 if s == 0 then off else StPrim SllOp [off, StInt s]
126 shift DoubleRep = 3::Integer
127 shift CharRep = 0::Integer
128 shift _ = IF_ARCH_alpha(3,2)
132 maybeImm :: StixTree -> Maybe Imm
134 maybeImm (StLitLbl s) = Just (ImmLab s)
135 maybeImm (StCLbl l) = Just (ImmCLbl l)
137 maybeImm (StIndex rep (StCLbl l) (StInt off)) =
138 Just (ImmIndex l (fromInteger (off * sizeOf rep)))
141 | i >= toInteger minInt && i <= toInteger maxInt
142 = Just (ImmInt (fromInteger i))
144 = Just (ImmInteger i)
149 %************************************************************************
151 \subsection{The @Register@ type}
153 %************************************************************************
155 @Register@s passed up the tree. If the stix code forces the register
156 to live in a pre-decided machine register, it comes out as @Fixed@;
157 otherwise, it comes out as @Any@, and the parent can decide which
158 register to put it in.
162 = Fixed PrimRep Reg InstrBlock
163 | Any PrimRep (Reg -> InstrBlock)
165 registerCode :: Register -> Reg -> InstrBlock
166 registerCode (Fixed _ _ code) reg = code
167 registerCode (Any _ code) reg = code reg
169 registerCodeF (Fixed _ _ code) = code
170 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
172 registerCodeA (Any _ code) = code
173 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
175 registerName :: Register -> Reg -> Reg
176 registerName (Fixed _ reg _) _ = reg
177 registerName (Any _ _) reg = reg
179 registerNameF (Fixed _ reg _) = reg
180 registerNameF (Any _ _) = pprPanic "registerNameF" empty
182 registerRep :: Register -> PrimRep
183 registerRep (Fixed pk _ _) = pk
184 registerRep (Any pk _) = pk
186 {-# INLINE registerCode #-}
187 {-# INLINE registerCodeF #-}
188 {-# INLINE registerName #-}
189 {-# INLINE registerNameF #-}
190 {-# INLINE registerRep #-}
191 {-# INLINE isFixed #-}
194 isFixed, isAny :: Register -> Bool
195 isFixed (Fixed _ _ _) = True
196 isFixed (Any _ _) = False
198 isAny = not . isFixed
201 Generate code to get a subtree into a @Register@:
203 getRegister :: StixTree -> NatM Register
205 getRegister (StReg (StixMagicId stgreg))
206 = case (magicIdRegMaybe stgreg) of
207 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
210 getRegister (StReg (StixTemp u pk))
211 = returnNat (Fixed pk (UnmappedReg u pk) nilOL)
213 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
215 getRegister (StCall fn cconv kind args)
216 = genCCall fn cconv kind args `thenNat` \ call ->
217 returnNat (Fixed kind reg call)
219 reg = if isFloatingRep kind
220 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
221 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
223 getRegister (StString s)
224 = getNatLabelNCG `thenNat` \ lbl ->
226 imm_lbl = ImmCLbl lbl
231 ASCII True (_UNPK_ s),
233 #if alpha_TARGET_ARCH
234 LDA dst (AddrImm imm_lbl)
237 MOV L (OpImm imm_lbl) (OpReg dst)
239 #if sparc_TARGET_ARCH
240 SETHI (HI imm_lbl) dst,
241 OR False dst (RIImm (LO imm_lbl)) dst
245 returnNat (Any PtrRep code)
249 -- end of machine-"independent" bit; here we go on the rest...
251 #if alpha_TARGET_ARCH
253 getRegister (StDouble d)
254 = getNatLabelNCG `thenNat` \ lbl ->
255 getNewRegNCG PtrRep `thenNat` \ tmp ->
256 let code dst = mkSeqInstrs [
259 DATA TF [ImmLab (rational d)],
261 LDA tmp (AddrImm (ImmCLbl lbl)),
262 LD TF dst (AddrReg tmp)]
264 returnNat (Any DoubleRep code)
266 getRegister (StPrim primop [x]) -- unary PrimOps
268 IntNegOp -> trivialUCode (NEG Q False) x
270 NotOp -> trivialUCode NOT x
272 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
273 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
275 OrdOp -> coerceIntCode IntRep x
278 Float2IntOp -> coerceFP2Int x
279 Int2FloatOp -> coerceInt2FP pr x
280 Double2IntOp -> coerceFP2Int x
281 Int2DoubleOp -> coerceInt2FP pr x
283 Double2FloatOp -> coerceFltCode x
284 Float2DoubleOp -> coerceFltCode x
286 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
288 fn = case other_op of
289 FloatExpOp -> SLIT("exp")
290 FloatLogOp -> SLIT("log")
291 FloatSqrtOp -> SLIT("sqrt")
292 FloatSinOp -> SLIT("sin")
293 FloatCosOp -> SLIT("cos")
294 FloatTanOp -> SLIT("tan")
295 FloatAsinOp -> SLIT("asin")
296 FloatAcosOp -> SLIT("acos")
297 FloatAtanOp -> SLIT("atan")
298 FloatSinhOp -> SLIT("sinh")
299 FloatCoshOp -> SLIT("cosh")
300 FloatTanhOp -> SLIT("tanh")
301 DoubleExpOp -> SLIT("exp")
302 DoubleLogOp -> SLIT("log")
303 DoubleSqrtOp -> SLIT("sqrt")
304 DoubleSinOp -> SLIT("sin")
305 DoubleCosOp -> SLIT("cos")
306 DoubleTanOp -> SLIT("tan")
307 DoubleAsinOp -> SLIT("asin")
308 DoubleAcosOp -> SLIT("acos")
309 DoubleAtanOp -> SLIT("atan")
310 DoubleSinhOp -> SLIT("sinh")
311 DoubleCoshOp -> SLIT("cosh")
312 DoubleTanhOp -> SLIT("tanh")
314 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
316 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
318 CharGtOp -> trivialCode (CMP LTT) y x
319 CharGeOp -> trivialCode (CMP LE) y x
320 CharEqOp -> trivialCode (CMP EQQ) x y
321 CharNeOp -> int_NE_code x y
322 CharLtOp -> trivialCode (CMP LTT) x y
323 CharLeOp -> trivialCode (CMP LE) x y
325 IntGtOp -> trivialCode (CMP LTT) y x
326 IntGeOp -> trivialCode (CMP LE) y x
327 IntEqOp -> trivialCode (CMP EQQ) x y
328 IntNeOp -> int_NE_code x y
329 IntLtOp -> trivialCode (CMP LTT) x y
330 IntLeOp -> trivialCode (CMP LE) x y
332 WordGtOp -> trivialCode (CMP ULT) y x
333 WordGeOp -> trivialCode (CMP ULE) x y
334 WordEqOp -> trivialCode (CMP EQQ) x y
335 WordNeOp -> int_NE_code x y
336 WordLtOp -> trivialCode (CMP ULT) x y
337 WordLeOp -> trivialCode (CMP ULE) x y
339 AddrGtOp -> trivialCode (CMP ULT) y x
340 AddrGeOp -> trivialCode (CMP ULE) y x
341 AddrEqOp -> trivialCode (CMP EQQ) x y
342 AddrNeOp -> int_NE_code x y
343 AddrLtOp -> trivialCode (CMP ULT) x y
344 AddrLeOp -> trivialCode (CMP ULE) x y
346 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
347 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
348 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
349 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
350 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
351 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
353 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
354 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
355 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
356 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
357 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
358 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
360 IntAddOp -> trivialCode (ADD Q False) x y
361 IntSubOp -> trivialCode (SUB Q False) x y
362 IntMulOp -> trivialCode (MUL Q False) x y
363 IntQuotOp -> trivialCode (DIV Q False) x y
364 IntRemOp -> trivialCode (REM Q False) x y
366 WordQuotOp -> trivialCode (DIV Q True) x y
367 WordRemOp -> trivialCode (REM Q True) x y
369 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
370 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
371 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
372 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
374 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
375 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
376 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
377 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
379 AndOp -> trivialCode AND x y
380 OrOp -> trivialCode OR x y
381 XorOp -> trivialCode XOR x y
382 SllOp -> trivialCode SLL x y
383 SrlOp -> trivialCode SRL x y
385 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
386 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
387 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
389 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
390 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
392 {- ------------------------------------------------------------
393 Some bizarre special code for getting condition codes into
394 registers. Integer non-equality is a test for equality
395 followed by an XOR with 1. (Integer comparisons always set
396 the result register to 0 or 1.) Floating point comparisons of
397 any kind leave the result in a floating point register, so we
398 need to wrangle an integer register out of things.
400 int_NE_code :: StixTree -> StixTree -> NatM Register
403 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
404 getNewRegNCG IntRep `thenNat` \ tmp ->
406 code = registerCode register tmp
407 src = registerName register tmp
408 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
410 returnNat (Any IntRep code__2)
412 {- ------------------------------------------------------------
413 Comments for int_NE_code also apply to cmpF_code
416 :: (Reg -> Reg -> Reg -> Instr)
418 -> StixTree -> StixTree
421 cmpF_code instr cond x y
422 = trivialFCode pr instr x y `thenNat` \ register ->
423 getNewRegNCG DoubleRep `thenNat` \ tmp ->
424 getNatLabelNCG `thenNat` \ lbl ->
426 code = registerCode register tmp
427 result = registerName register tmp
429 code__2 dst = code . mkSeqInstrs [
430 OR zeroh (RIImm (ImmInt 1)) dst,
431 BF cond result (ImmCLbl lbl),
432 OR zeroh (RIReg zeroh) dst,
435 returnNat (Any IntRep code__2)
437 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
438 ------------------------------------------------------------
440 getRegister (StInd pk mem)
441 = getAmode mem `thenNat` \ amode ->
443 code = amodeCode amode
444 src = amodeAddr amode
445 size = primRepToSize pk
446 code__2 dst = code . mkSeqInstr (LD size dst src)
448 returnNat (Any pk code__2)
450 getRegister (StInt i)
453 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
455 returnNat (Any IntRep code)
458 code dst = mkSeqInstr (LDI Q dst src)
460 returnNat (Any IntRep code)
462 src = ImmInt (fromInteger i)
467 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
469 returnNat (Any PtrRep code)
472 imm__2 = case imm of Just x -> x
474 #endif {- alpha_TARGET_ARCH -}
475 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
478 getRegister (StDouble d)
481 = let code dst = unitOL (GLDZ dst)
482 in trace "nativeGen: GLDZ"
483 (returnNat (Any DoubleRep code))
486 = let code dst = unitOL (GLD1 dst)
487 in trace "nativeGen: GLD1"
488 returnNat (Any DoubleRep code)
491 = getNatLabelNCG `thenNat` \ lbl ->
492 let code dst = toOL [
495 DATA DF [ImmDouble d],
497 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
500 returnNat (Any DoubleRep code)
502 -- Calculate the offset for (i+1) words above the _initial_
503 -- %esp value by first determining the current offset of it.
504 getRegister (StScratchWord i)
506 = getDeltaNat `thenNat` \ current_stack_offset ->
507 let j = i+1 - (current_stack_offset `div` 4)
509 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
511 returnNat (Any PtrRep code)
513 getRegister (StPrim primop [x]) -- unary PrimOps
515 IntNegOp -> trivialUCode (NEGI L) x
516 NotOp -> trivialUCode (NOT L) x
518 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
519 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
521 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
522 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
524 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
525 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
527 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
528 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
530 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
531 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
533 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
534 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
536 OrdOp -> coerceIntCode IntRep x
539 Float2IntOp -> coerceFP2Int x
540 Int2FloatOp -> coerceInt2FP FloatRep x
541 Double2IntOp -> coerceFP2Int x
542 Int2DoubleOp -> coerceInt2FP DoubleRep x
546 fixed_x = if is_float_op -- promote to double
547 then StPrim Float2DoubleOp [x]
550 getRegister (StCall fn cCallConv DoubleRep [x])
554 FloatExpOp -> (True, SLIT("exp"))
555 FloatLogOp -> (True, SLIT("log"))
557 FloatAsinOp -> (True, SLIT("asin"))
558 FloatAcosOp -> (True, SLIT("acos"))
559 FloatAtanOp -> (True, SLIT("atan"))
561 FloatSinhOp -> (True, SLIT("sinh"))
562 FloatCoshOp -> (True, SLIT("cosh"))
563 FloatTanhOp -> (True, SLIT("tanh"))
565 DoubleExpOp -> (False, SLIT("exp"))
566 DoubleLogOp -> (False, SLIT("log"))
568 DoubleAsinOp -> (False, SLIT("asin"))
569 DoubleAcosOp -> (False, SLIT("acos"))
570 DoubleAtanOp -> (False, SLIT("atan"))
572 DoubleSinhOp -> (False, SLIT("sinh"))
573 DoubleCoshOp -> (False, SLIT("cosh"))
574 DoubleTanhOp -> (False, SLIT("tanh"))
577 -> pprPanic "getRegister(x86,unary primop)"
578 (pprStixTrees [StPrim primop [x]])
580 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
582 CharGtOp -> condIntReg GTT x y
583 CharGeOp -> condIntReg GE x y
584 CharEqOp -> condIntReg EQQ x y
585 CharNeOp -> condIntReg NE x y
586 CharLtOp -> condIntReg LTT x y
587 CharLeOp -> condIntReg LE x y
589 IntGtOp -> condIntReg GTT x y
590 IntGeOp -> condIntReg GE x y
591 IntEqOp -> condIntReg EQQ x y
592 IntNeOp -> condIntReg NE x y
593 IntLtOp -> condIntReg LTT x y
594 IntLeOp -> condIntReg LE x y
596 WordGtOp -> condIntReg GU x y
597 WordGeOp -> condIntReg GEU x y
598 WordEqOp -> condIntReg EQQ x y
599 WordNeOp -> condIntReg NE x y
600 WordLtOp -> condIntReg LU x y
601 WordLeOp -> condIntReg LEU x y
603 AddrGtOp -> condIntReg GU x y
604 AddrGeOp -> condIntReg GEU x y
605 AddrEqOp -> condIntReg EQQ x y
606 AddrNeOp -> condIntReg NE x y
607 AddrLtOp -> condIntReg LU x y
608 AddrLeOp -> condIntReg LEU x y
610 FloatGtOp -> condFltReg GTT x y
611 FloatGeOp -> condFltReg GE x y
612 FloatEqOp -> condFltReg EQQ x y
613 FloatNeOp -> condFltReg NE x y
614 FloatLtOp -> condFltReg LTT x y
615 FloatLeOp -> condFltReg LE x y
617 DoubleGtOp -> condFltReg GTT x y
618 DoubleGeOp -> condFltReg GE x y
619 DoubleEqOp -> condFltReg EQQ x y
620 DoubleNeOp -> condFltReg NE x y
621 DoubleLtOp -> condFltReg LTT x y
622 DoubleLeOp -> condFltReg LE x y
624 IntAddOp -> add_code L x y
625 IntSubOp -> sub_code L x y
626 IntQuotOp -> quot_code L x y True{-division-}
627 IntRemOp -> quot_code L x y False{-remainder-}
628 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
630 FloatAddOp -> trivialFCode FloatRep GADD x y
631 FloatSubOp -> trivialFCode FloatRep GSUB x y
632 FloatMulOp -> trivialFCode FloatRep GMUL x y
633 FloatDivOp -> trivialFCode FloatRep GDIV x y
635 DoubleAddOp -> trivialFCode DoubleRep GADD x y
636 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
637 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
638 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
640 AndOp -> let op = AND L in trivialCode op (Just op) x y
641 OrOp -> let op = OR L in trivialCode op (Just op) x y
642 XorOp -> let op = XOR L in trivialCode op (Just op) x y
644 {- Shift ops on x86s have constraints on their source, it
645 either has to be Imm, CL or 1
646 => trivialCode's is not restrictive enough (sigh.)
649 SllOp -> shift_code (SHL L) x y {-False-}
650 SrlOp -> shift_code (SHR L) x y {-False-}
651 ISllOp -> shift_code (SHL L) x y {-False-}
652 ISraOp -> shift_code (SAR L) x y {-False-}
653 ISrlOp -> shift_code (SHR L) x y {-False-}
655 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
656 [promote x, promote y])
657 where promote x = StPrim Float2DoubleOp [x]
658 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
661 -> pprPanic "getRegister(x86,dyadic primop)"
662 (pprStixTrees [StPrim primop [x, y]])
666 shift_code :: (Imm -> Operand -> Instr)
671 {- Case1: shift length as immediate -}
672 -- Code is the same as the first eq. for trivialCode -- sigh.
673 shift_code instr x y{-amount-}
675 = getRegister x `thenNat` \ regx ->
678 then registerCodeA regx dst `bind` \ code_x ->
680 instr imm__2 (OpReg dst)
681 else registerCodeF regx `bind` \ code_x ->
682 registerNameF regx `bind` \ r_x ->
684 MOV L (OpReg r_x) (OpReg dst) `snocOL`
685 instr imm__2 (OpReg dst)
687 returnNat (Any IntRep mkcode)
690 imm__2 = case imm of Just x -> x
692 {- Case2: shift length is complex (non-immediate) -}
693 -- Since ECX is always used as a spill temporary, we can't
694 -- use it here to do non-immediate shifts. No big deal --
695 -- they are only very rare, and we can use an equivalent
696 -- test-and-jump sequence which doesn't use ECX.
697 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
698 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
699 shift_code instr x y{-amount-}
700 = getRegister x `thenNat` \ register1 ->
701 getRegister y `thenNat` \ register2 ->
702 getNatLabelNCG `thenNat` \ lbl_test3 ->
703 getNatLabelNCG `thenNat` \ lbl_test2 ->
704 getNatLabelNCG `thenNat` \ lbl_test1 ->
705 getNatLabelNCG `thenNat` \ lbl_test0 ->
706 getNatLabelNCG `thenNat` \ lbl_after ->
707 getNewRegNCG IntRep `thenNat` \ tmp ->
709 = let src_val = registerName register1 dst
710 code_val = registerCode register1 dst
711 src_amt = registerName register2 tmp
712 code_amt = registerCode register2 tmp
717 MOV L (OpReg src_amt) r_tmp `appOL`
719 MOV L (OpReg src_val) r_dst `appOL`
721 COMMENT (_PK_ "begin shift sequence"),
722 MOV L (OpReg src_val) r_dst,
723 MOV L (OpReg src_amt) r_tmp,
725 BT L (ImmInt 4) r_tmp,
727 instr (ImmInt 16) r_dst,
730 BT L (ImmInt 3) r_tmp,
732 instr (ImmInt 8) r_dst,
735 BT L (ImmInt 2) r_tmp,
737 instr (ImmInt 4) r_dst,
740 BT L (ImmInt 1) r_tmp,
742 instr (ImmInt 2) r_dst,
745 BT L (ImmInt 0) r_tmp,
747 instr (ImmInt 1) r_dst,
750 COMMENT (_PK_ "end shift sequence")
753 returnNat (Any IntRep code__2)
756 add_code :: Size -> StixTree -> StixTree -> NatM Register
758 add_code sz x (StInt y)
759 = getRegister x `thenNat` \ register ->
760 getNewRegNCG IntRep `thenNat` \ tmp ->
762 code = registerCode register tmp
763 src1 = registerName register tmp
764 src2 = ImmInt (fromInteger y)
767 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
770 returnNat (Any IntRep code__2)
772 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
775 sub_code :: Size -> StixTree -> StixTree -> NatM Register
777 sub_code sz x (StInt y)
778 = getRegister x `thenNat` \ register ->
779 getNewRegNCG IntRep `thenNat` \ tmp ->
781 code = registerCode register tmp
782 src1 = registerName register tmp
783 src2 = ImmInt (-(fromInteger y))
786 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
789 returnNat (Any IntRep code__2)
791 sub_code sz x y = trivialCode (SUB sz) Nothing x y
796 -> StixTree -> StixTree
797 -> Bool -- True => division, False => remainder operation
800 -- x must go into eax, edx must be a sign-extension of eax, and y
801 -- should go in some other register (or memory), so that we get
802 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
803 -- to put y on the C stack, since that avoids tying up yet another
804 -- precious register.
806 quot_code sz x y is_division
807 = getRegister x `thenNat` \ register1 ->
808 getRegister y `thenNat` \ register2 ->
809 getNewRegNCG IntRep `thenNat` \ tmp ->
810 getDeltaNat `thenNat` \ delta ->
812 code1 = registerCode register1 tmp
813 src1 = registerName register1 tmp
814 code2 = registerCode register2 tmp
815 src2 = registerName register2 tmp
816 code__2 = code2 `snocOL` -- src2 := y
817 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
818 DELTA (delta-4) `appOL`
819 code1 `snocOL` -- src1 := x
820 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
822 IDIV sz (OpAddr (spRel 0)) `snocOL`
823 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
826 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
827 -----------------------
829 getRegister (StInd pk mem)
830 = getAmode mem `thenNat` \ amode ->
832 code = amodeCode amode
833 src = amodeAddr amode
834 size = primRepToSize pk
835 code__2 dst = code `snocOL`
836 if pk == DoubleRep || pk == FloatRep
837 then GLD size src dst
839 L -> MOV L (OpAddr src) (OpReg dst)
840 B -> MOVZxL B (OpAddr src) (OpReg dst)
842 returnNat (Any pk code__2)
844 getRegister (StInt i)
846 src = ImmInt (fromInteger i)
849 = unitOL (XOR L (OpReg dst) (OpReg dst))
851 = unitOL (MOV L (OpImm src) (OpReg dst))
853 returnNat (Any IntRep code)
857 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
859 returnNat (Any PtrRep code)
861 = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
864 imm__2 = case imm of Just x -> x
866 #endif {- i386_TARGET_ARCH -}
867 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
868 #if sparc_TARGET_ARCH
870 getRegister (StDouble d)
871 = getNatLabelNCG `thenNat` \ lbl ->
872 getNewRegNCG PtrRep `thenNat` \ tmp ->
873 let code dst = mkSeqInstrs [
876 DATA DF [ImmDouble d],
878 SETHI (HI (ImmCLbl lbl)) tmp,
879 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
881 returnNat (Any DoubleRep code)
883 getRegister (StPrim primop [x]) -- unary PrimOps
885 IntNegOp -> trivialUCode (SUB False False g0) x
886 NotOp -> trivialUCode (XNOR False g0) x
888 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
890 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
892 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
893 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
895 OrdOp -> coerceIntCode IntRep x
898 Float2IntOp -> coerceFP2Int x
899 Int2FloatOp -> coerceInt2FP FloatRep x
900 Double2IntOp -> coerceFP2Int x
901 Int2DoubleOp -> coerceInt2FP DoubleRep x
905 fixed_x = if is_float_op -- promote to double
906 then StPrim Float2DoubleOp [x]
909 getRegister (StCall fn cCallConv DoubleRep [x])
913 FloatExpOp -> (True, SLIT("exp"))
914 FloatLogOp -> (True, SLIT("log"))
915 FloatSqrtOp -> (True, SLIT("sqrt"))
917 FloatSinOp -> (True, SLIT("sin"))
918 FloatCosOp -> (True, SLIT("cos"))
919 FloatTanOp -> (True, SLIT("tan"))
921 FloatAsinOp -> (True, SLIT("asin"))
922 FloatAcosOp -> (True, SLIT("acos"))
923 FloatAtanOp -> (True, SLIT("atan"))
925 FloatSinhOp -> (True, SLIT("sinh"))
926 FloatCoshOp -> (True, SLIT("cosh"))
927 FloatTanhOp -> (True, SLIT("tanh"))
929 DoubleExpOp -> (False, SLIT("exp"))
930 DoubleLogOp -> (False, SLIT("log"))
931 DoubleSqrtOp -> (True, SLIT("sqrt"))
933 DoubleSinOp -> (False, SLIT("sin"))
934 DoubleCosOp -> (False, SLIT("cos"))
935 DoubleTanOp -> (False, SLIT("tan"))
937 DoubleAsinOp -> (False, SLIT("asin"))
938 DoubleAcosOp -> (False, SLIT("acos"))
939 DoubleAtanOp -> (False, SLIT("atan"))
941 DoubleSinhOp -> (False, SLIT("sinh"))
942 DoubleCoshOp -> (False, SLIT("cosh"))
943 DoubleTanhOp -> (False, SLIT("tanh"))
944 _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
946 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
948 CharGtOp -> condIntReg GTT x y
949 CharGeOp -> condIntReg GE x y
950 CharEqOp -> condIntReg EQQ x y
951 CharNeOp -> condIntReg NE x y
952 CharLtOp -> condIntReg LTT x y
953 CharLeOp -> condIntReg LE x y
955 IntGtOp -> condIntReg GTT x y
956 IntGeOp -> condIntReg GE x y
957 IntEqOp -> condIntReg EQQ x y
958 IntNeOp -> condIntReg NE x y
959 IntLtOp -> condIntReg LTT x y
960 IntLeOp -> condIntReg LE x y
962 WordGtOp -> condIntReg GU x y
963 WordGeOp -> condIntReg GEU x y
964 WordEqOp -> condIntReg EQQ x y
965 WordNeOp -> condIntReg NE x y
966 WordLtOp -> condIntReg LU x y
967 WordLeOp -> condIntReg LEU x y
969 AddrGtOp -> condIntReg GU x y
970 AddrGeOp -> condIntReg GEU x y
971 AddrEqOp -> condIntReg EQQ x y
972 AddrNeOp -> condIntReg NE x y
973 AddrLtOp -> condIntReg LU x y
974 AddrLeOp -> condIntReg LEU x y
976 FloatGtOp -> condFltReg GTT x y
977 FloatGeOp -> condFltReg GE x y
978 FloatEqOp -> condFltReg EQQ x y
979 FloatNeOp -> condFltReg NE x y
980 FloatLtOp -> condFltReg LTT x y
981 FloatLeOp -> condFltReg LE x y
983 DoubleGtOp -> condFltReg GTT x y
984 DoubleGeOp -> condFltReg GE x y
985 DoubleEqOp -> condFltReg EQQ x y
986 DoubleNeOp -> condFltReg NE x y
987 DoubleLtOp -> condFltReg LTT x y
988 DoubleLeOp -> condFltReg LE x y
990 IntAddOp -> trivialCode (ADD False False) x y
991 IntSubOp -> trivialCode (SUB False False) x y
993 -- ToDo: teach about V8+ SPARC mul/div instructions
994 IntMulOp -> imul_div SLIT(".umul") x y
995 IntQuotOp -> imul_div SLIT(".div") x y
996 IntRemOp -> imul_div SLIT(".rem") x y
998 FloatAddOp -> trivialFCode FloatRep FADD x y
999 FloatSubOp -> trivialFCode FloatRep FSUB x y
1000 FloatMulOp -> trivialFCode FloatRep FMUL x y
1001 FloatDivOp -> trivialFCode FloatRep FDIV x y
1003 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1004 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1005 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1006 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1008 AndOp -> trivialCode (AND False) x y
1009 OrOp -> trivialCode (OR False) x y
1010 XorOp -> trivialCode (XOR False) x y
1011 SllOp -> trivialCode SLL x y
1012 SrlOp -> trivialCode SRL x y
1014 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1015 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1016 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1018 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1019 where promote x = StPrim Float2DoubleOp [x]
1020 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1021 -- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1023 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1025 getRegister (StInd pk mem)
1026 = getAmode mem `thenNat` \ amode ->
1028 code = amodeCode amode
1029 src = amodeAddr amode
1030 size = primRepToSize pk
1031 code__2 dst = code . mkSeqInstr (LD size src dst)
1033 returnNat (Any pk code__2)
1035 getRegister (StInt i)
1038 src = ImmInt (fromInteger i)
1039 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1041 returnNat (Any IntRep code)
1046 code dst = mkSeqInstrs [
1047 SETHI (HI imm__2) dst,
1048 OR False dst (RIImm (LO imm__2)) dst]
1050 returnNat (Any PtrRep code)
1053 imm__2 = case imm of Just x -> x
1055 #endif {- sparc_TARGET_ARCH -}
1058 %************************************************************************
1060 \subsection{The @Amode@ type}
1062 %************************************************************************
1064 @Amode@s: Memory addressing modes passed up the tree.
1066 data Amode = Amode MachRegsAddr InstrBlock
1068 amodeAddr (Amode addr _) = addr
1069 amodeCode (Amode _ code) = code
1072 Now, given a tree (the argument to an StInd) that references memory,
1073 produce a suitable addressing mode.
1075 A Rule of the Game (tm) for Amodes: use of the addr bit must
1076 immediately follow use of the code part, since the code part puts
1077 values in registers which the addr then refers to. So you can't put
1078 anything in between, lest it overwrite some of those registers. If
1079 you need to do some other computation between the code part and use of
1080 the addr bit, first store the effective address from the amode in a
1081 temporary, then do the other computation, and then use the temporary:
1085 ... other computation ...
1089 getAmode :: StixTree -> NatM Amode
1091 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1093 #if alpha_TARGET_ARCH
1095 getAmode (StPrim IntSubOp [x, StInt i])
1096 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1097 getRegister x `thenNat` \ register ->
1099 code = registerCode register tmp
1100 reg = registerName register tmp
1101 off = ImmInt (-(fromInteger i))
1103 returnNat (Amode (AddrRegImm reg off) code)
1105 getAmode (StPrim IntAddOp [x, StInt i])
1106 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1107 getRegister x `thenNat` \ register ->
1109 code = registerCode register tmp
1110 reg = registerName register tmp
1111 off = ImmInt (fromInteger i)
1113 returnNat (Amode (AddrRegImm reg off) code)
1117 = returnNat (Amode (AddrImm imm__2) id)
1120 imm__2 = case imm of Just x -> x
1123 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1124 getRegister other `thenNat` \ register ->
1126 code = registerCode register tmp
1127 reg = registerName register tmp
1129 returnNat (Amode (AddrReg reg) code)
1131 #endif {- alpha_TARGET_ARCH -}
1132 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1133 #if i386_TARGET_ARCH
1135 getAmode (StPrim IntSubOp [x, StInt i])
1136 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1137 getRegister x `thenNat` \ register ->
1139 code = registerCode register tmp
1140 reg = registerName register tmp
1141 off = ImmInt (-(fromInteger i))
1143 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1145 getAmode (StPrim IntAddOp [x, StInt i])
1147 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1150 imm__2 = case imm of Just x -> x
1152 getAmode (StPrim IntAddOp [x, StInt i])
1153 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1154 getRegister x `thenNat` \ register ->
1156 code = registerCode register tmp
1157 reg = registerName register tmp
1158 off = ImmInt (fromInteger i)
1160 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1162 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1163 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1164 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1165 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1166 getRegister x `thenNat` \ register1 ->
1167 getRegister y `thenNat` \ register2 ->
1169 code1 = registerCode register1 tmp1
1170 reg1 = registerName register1 tmp1
1171 code2 = registerCode register2 tmp2
1172 reg2 = registerName register2 tmp2
1173 code__2 = code1 `appOL` code2
1174 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1176 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1181 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1184 imm__2 = case imm of Just x -> x
1187 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1188 getRegister other `thenNat` \ register ->
1190 code = registerCode register tmp
1191 reg = registerName register tmp
1193 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1195 #endif {- i386_TARGET_ARCH -}
1196 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1197 #if sparc_TARGET_ARCH
1199 getAmode (StPrim IntSubOp [x, StInt i])
1201 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1202 getRegister x `thenNat` \ register ->
1204 code = registerCode register tmp
1205 reg = registerName register tmp
1206 off = ImmInt (-(fromInteger i))
1208 returnNat (Amode (AddrRegImm reg off) code)
1211 getAmode (StPrim IntAddOp [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 (AddrRegImm reg off) code)
1222 getAmode (StPrim IntAddOp [x, y])
1223 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1224 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1225 getRegister x `thenNat` \ register1 ->
1226 getRegister y `thenNat` \ register2 ->
1228 code1 = registerCode register1 tmp1 []
1229 reg1 = registerName register1 tmp1
1230 code2 = registerCode register2 tmp2 []
1231 reg2 = registerName register2 tmp2
1232 code__2 = asmSeqThen [code1, code2]
1234 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1238 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1240 code = mkSeqInstr (SETHI (HI imm__2) tmp)
1242 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1245 imm__2 = case imm of Just x -> x
1248 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1249 getRegister other `thenNat` \ register ->
1251 code = registerCode register tmp
1252 reg = registerName register tmp
1255 returnNat (Amode (AddrRegImm reg off) code)
1257 #endif {- sparc_TARGET_ARCH -}
1260 %************************************************************************
1262 \subsection{The @CondCode@ type}
1264 %************************************************************************
1266 Condition codes passed up the tree.
1268 data CondCode = CondCode Bool Cond InstrBlock
1270 condName (CondCode _ cond _) = cond
1271 condFloat (CondCode is_float _ _) = is_float
1272 condCode (CondCode _ _ code) = code
1275 Set up a condition code for a conditional branch.
1278 getCondCode :: StixTree -> NatM CondCode
1280 #if alpha_TARGET_ARCH
1281 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1282 #endif {- alpha_TARGET_ARCH -}
1283 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1285 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1286 -- yes, they really do seem to want exactly the same!
1288 getCondCode (StPrim primop [x, y])
1290 CharGtOp -> condIntCode GTT x y
1291 CharGeOp -> condIntCode GE x y
1292 CharEqOp -> condIntCode EQQ x y
1293 CharNeOp -> condIntCode NE x y
1294 CharLtOp -> condIntCode LTT x y
1295 CharLeOp -> condIntCode LE x y
1297 IntGtOp -> condIntCode GTT x y
1298 IntGeOp -> condIntCode GE x y
1299 IntEqOp -> condIntCode EQQ x y
1300 IntNeOp -> condIntCode NE x y
1301 IntLtOp -> condIntCode LTT x y
1302 IntLeOp -> condIntCode LE x y
1304 WordGtOp -> condIntCode GU x y
1305 WordGeOp -> condIntCode GEU x y
1306 WordEqOp -> condIntCode EQQ x y
1307 WordNeOp -> condIntCode NE x y
1308 WordLtOp -> condIntCode LU x y
1309 WordLeOp -> condIntCode LEU x y
1311 AddrGtOp -> condIntCode GU x y
1312 AddrGeOp -> condIntCode GEU x y
1313 AddrEqOp -> condIntCode EQQ x y
1314 AddrNeOp -> condIntCode NE x y
1315 AddrLtOp -> condIntCode LU x y
1316 AddrLeOp -> condIntCode LEU x y
1318 FloatGtOp -> condFltCode GTT x y
1319 FloatGeOp -> condFltCode GE x y
1320 FloatEqOp -> condFltCode EQQ x y
1321 FloatNeOp -> condFltCode NE x y
1322 FloatLtOp -> condFltCode LTT x y
1323 FloatLeOp -> condFltCode LE x y
1325 DoubleGtOp -> condFltCode GTT x y
1326 DoubleGeOp -> condFltCode GE x y
1327 DoubleEqOp -> condFltCode EQQ x y
1328 DoubleNeOp -> condFltCode NE x y
1329 DoubleLtOp -> condFltCode LTT x y
1330 DoubleLeOp -> condFltCode LE x y
1332 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1337 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1338 passed back up the tree.
1341 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1343 #if alpha_TARGET_ARCH
1344 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1345 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1346 #endif {- alpha_TARGET_ARCH -}
1348 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1349 #if i386_TARGET_ARCH
1351 -- memory vs immediate
1352 condIntCode cond (StInd pk x) y
1354 = getAmode x `thenNat` \ amode ->
1356 code1 = amodeCode amode
1357 x__2 = amodeAddr amode
1358 sz = primRepToSize pk
1359 code__2 = code1 `snocOL`
1360 CMP sz (OpImm imm__2) (OpAddr x__2)
1362 returnNat (CondCode False cond code__2)
1365 imm__2 = case imm of Just x -> x
1368 condIntCode cond x (StInt 0)
1369 = getRegister x `thenNat` \ register1 ->
1370 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1372 code1 = registerCode register1 tmp1
1373 src1 = registerName register1 tmp1
1374 code__2 = code1 `snocOL`
1375 TEST L (OpReg src1) (OpReg src1)
1377 returnNat (CondCode False cond code__2)
1379 -- anything vs immediate
1380 condIntCode cond x y
1382 = getRegister x `thenNat` \ register1 ->
1383 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1385 code1 = registerCode register1 tmp1
1386 src1 = registerName register1 tmp1
1387 code__2 = code1 `snocOL`
1388 CMP L (OpImm imm__2) (OpReg src1)
1390 returnNat (CondCode False cond code__2)
1393 imm__2 = case imm of Just x -> x
1395 -- memory vs anything
1396 condIntCode cond (StInd pk x) y
1397 = getAmode x `thenNat` \ amode_x ->
1398 getRegister y `thenNat` \ reg_y ->
1399 getNewRegNCG IntRep `thenNat` \ tmp ->
1401 c_x = amodeCode amode_x
1402 am_x = amodeAddr amode_x
1403 c_y = registerCode reg_y tmp
1404 r_y = registerName reg_y tmp
1405 sz = primRepToSize pk
1407 -- optimisation: if there's no code for x, just an amode,
1408 -- use whatever reg y winds up in. Assumes that c_y doesn't
1409 -- clobber any regs in the amode am_x, which I'm not sure is
1410 -- justified. The otherwise clause makes the same assumption.
1411 code__2 | isNilOL c_x
1413 CMP sz (OpReg r_y) (OpAddr am_x)
1417 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1419 CMP sz (OpReg tmp) (OpAddr am_x)
1421 returnNat (CondCode False cond code__2)
1423 -- anything vs memory
1425 condIntCode cond y (StInd pk x)
1426 = getAmode x `thenNat` \ amode_x ->
1427 getRegister y `thenNat` \ reg_y ->
1428 getNewRegNCG IntRep `thenNat` \ tmp ->
1430 c_x = amodeCode amode_x
1431 am_x = amodeAddr amode_x
1432 c_y = registerCode reg_y tmp
1433 r_y = registerName reg_y tmp
1434 sz = primRepToSize pk
1435 -- same optimisation and nagging doubts as previous clause
1436 code__2 | isNilOL c_x
1438 CMP sz (OpAddr am_x) (OpReg r_y)
1442 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1444 CMP sz (OpAddr am_x) (OpReg tmp)
1446 returnNat (CondCode False cond code__2)
1448 -- anything vs anything
1449 condIntCode cond x y
1450 = getRegister x `thenNat` \ register1 ->
1451 getRegister y `thenNat` \ register2 ->
1452 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1453 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1455 code1 = registerCode register1 tmp1
1456 src1 = registerName register1 tmp1
1457 code2 = registerCode register2 tmp2
1458 src2 = registerName register2 tmp2
1459 code__2 = code1 `snocOL`
1460 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1462 CMP L (OpReg src2) (OpReg tmp1)
1464 returnNat (CondCode False cond code__2)
1467 condFltCode cond x y
1468 = getRegister x `thenNat` \ register1 ->
1469 getRegister y `thenNat` \ register2 ->
1470 getNewRegNCG (registerRep register1)
1472 getNewRegNCG (registerRep register2)
1474 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1476 pk1 = registerRep register1
1477 code1 = registerCode register1 tmp1
1478 src1 = registerName register1 tmp1
1480 pk2 = registerRep register2
1481 code2 = registerCode register2 tmp2
1482 src2 = registerName register2 tmp2
1484 code__2 | isAny register1
1485 = code1 `appOL` -- result in tmp1
1487 GCMP (primRepToSize pk1) tmp1 src2
1491 GMOV src1 tmp1 `appOL`
1493 GCMP (primRepToSize pk1) tmp1 src2
1495 {- On the 486, the flags set by FP compare are the unsigned ones!
1496 (This looks like a HACK to me. WDP 96/03)
1498 fix_FP_cond :: Cond -> Cond
1500 fix_FP_cond GE = GEU
1501 fix_FP_cond GTT = GU
1502 fix_FP_cond LTT = LU
1503 fix_FP_cond LE = LEU
1504 fix_FP_cond any = any
1506 returnNat (CondCode True (fix_FP_cond cond) code__2)
1510 #endif {- i386_TARGET_ARCH -}
1511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1512 #if sparc_TARGET_ARCH
1514 condIntCode cond x (StInt y)
1516 = getRegister x `thenNat` \ register ->
1517 getNewRegNCG IntRep `thenNat` \ tmp ->
1519 code = registerCode register tmp
1520 src1 = registerName register tmp
1521 src2 = ImmInt (fromInteger y)
1522 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1524 returnNat (CondCode False cond code__2)
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 = asmSeqThen [code1, code2] .
1537 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1539 returnNat (CondCode False cond code__2)
1542 condFltCode cond x y
1543 = getRegister x `thenNat` \ register1 ->
1544 getRegister y `thenNat` \ register2 ->
1545 getNewRegNCG (registerRep register1)
1547 getNewRegNCG (registerRep register2)
1549 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1551 promote x = asmInstr (FxTOy F DF x tmp)
1553 pk1 = registerRep register1
1554 code1 = registerCode register1 tmp1
1555 src1 = registerName register1 tmp1
1557 pk2 = registerRep register2
1558 code2 = registerCode register2 tmp2
1559 src2 = registerName register2 tmp2
1563 asmSeqThen [code1 [], code2 []] .
1564 mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1565 else if pk1 == FloatRep then
1566 asmSeqThen [code1 (promote src1), code2 []] .
1567 mkSeqInstr (FCMP True DF tmp src2)
1569 asmSeqThen [code1 [], code2 (promote src2)] .
1570 mkSeqInstr (FCMP True DF src1 tmp)
1572 returnNat (CondCode True cond code__2)
1574 #endif {- sparc_TARGET_ARCH -}
1577 %************************************************************************
1579 \subsection{Generating assignments}
1581 %************************************************************************
1583 Assignments are really at the heart of the whole code generation
1584 business. Almost all top-level nodes of any real importance are
1585 assignments, which correspond to loads, stores, or register transfers.
1586 If we're really lucky, some of the register transfers will go away,
1587 because we can use the destination register to complete the code
1588 generation for the right hand side. This only fails when the right
1589 hand side is forced into a fixed register (e.g. the result of a call).
1592 assignIntCode, assignFltCode
1593 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1595 #if alpha_TARGET_ARCH
1597 assignIntCode pk (StInd _ dst) src
1598 = getNewRegNCG IntRep `thenNat` \ tmp ->
1599 getAmode dst `thenNat` \ amode ->
1600 getRegister src `thenNat` \ register ->
1602 code1 = amodeCode amode []
1603 dst__2 = amodeAddr amode
1604 code2 = registerCode register tmp []
1605 src__2 = registerName register tmp
1606 sz = primRepToSize pk
1607 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1611 assignIntCode pk dst src
1612 = getRegister dst `thenNat` \ register1 ->
1613 getRegister src `thenNat` \ register2 ->
1615 dst__2 = registerName register1 zeroh
1616 code = registerCode register2 dst__2
1617 src__2 = registerName register2 dst__2
1618 code__2 = if isFixed register2
1619 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1624 #endif {- alpha_TARGET_ARCH -}
1625 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1626 #if i386_TARGET_ARCH
1628 -- Destination of an assignment can only be reg or mem.
1629 -- This is the mem case.
1630 assignIntCode pk (StInd _ dst) src
1631 = getAmode dst `thenNat` \ amode ->
1632 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1633 getNewRegNCG PtrRep `thenNat` \ tmp ->
1635 -- In general, if the address computation for dst may require
1636 -- some insns preceding the addressing mode itself. So there's
1637 -- no guarantee that the code for dst and the code for src won't
1638 -- write the same register. This means either the address or
1639 -- the value needs to be copied into a temporary. We detect the
1640 -- common case where the amode has no code, and elide the copy.
1641 codea = amodeCode amode
1642 dst__a = amodeAddr amode
1644 code | isNilOL codea
1646 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1650 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1652 MOV (primRepToSize pk) opsrc
1653 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1659 -> NatM (InstrBlock,Operand) -- code, operator
1663 = returnNat (nilOL, OpImm imm_op)
1666 imm_op = case imm of Just x -> x
1669 = getRegister op `thenNat` \ register ->
1670 getNewRegNCG (registerRep register)
1672 let code = registerCode register tmp
1673 reg = registerName register tmp
1675 returnNat (code, OpReg reg)
1677 -- Assign; dst is a reg, rhs is mem
1678 assignIntCode pk dst (StInd pks src)
1679 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1680 getAmode src `thenNat` \ amode ->
1681 getRegister dst `thenNat` \ reg_dst ->
1683 c_addr = amodeCode amode
1684 am_addr = amodeAddr amode
1686 c_dst = registerCode reg_dst tmp -- should be empty
1687 r_dst = registerName reg_dst tmp
1688 szs = primRepToSize pks
1689 opc = case szs of L -> MOV L ; B -> MOVZxL B
1691 code | isNilOL c_dst
1693 opc (OpAddr am_addr) (OpReg r_dst)
1695 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1699 -- dst is a reg, but src could be anything
1700 assignIntCode pk dst src
1701 = getRegister dst `thenNat` \ registerd ->
1702 getRegister src `thenNat` \ registers ->
1703 getNewRegNCG IntRep `thenNat` \ tmp ->
1705 r_dst = registerName registerd tmp
1706 c_dst = registerCode registerd tmp -- should be empty
1707 r_src = registerName registers r_dst
1708 c_src = registerCode registers r_dst
1710 code | isNilOL c_dst
1712 MOV L (OpReg r_src) (OpReg r_dst)
1714 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1718 #endif {- i386_TARGET_ARCH -}
1719 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1720 #if sparc_TARGET_ARCH
1722 assignIntCode pk (StInd _ dst) src
1723 = getNewRegNCG IntRep `thenNat` \ tmp ->
1724 getAmode dst `thenNat` \ amode ->
1725 getRegister src `thenNat` \ register ->
1727 code1 = amodeCode amode []
1728 dst__2 = amodeAddr amode
1729 code2 = registerCode register tmp []
1730 src__2 = registerName register tmp
1731 sz = primRepToSize pk
1732 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1736 assignIntCode pk dst src
1737 = getRegister dst `thenNat` \ register1 ->
1738 getRegister src `thenNat` \ register2 ->
1740 dst__2 = registerName register1 g0
1741 code = registerCode register2 dst__2
1742 src__2 = registerName register2 dst__2
1743 code__2 = if isFixed register2
1744 then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1749 #endif {- sparc_TARGET_ARCH -}
1752 % --------------------------------
1753 Floating-point assignments:
1754 % --------------------------------
1756 #if alpha_TARGET_ARCH
1758 assignFltCode pk (StInd _ dst) src
1759 = getNewRegNCG pk `thenNat` \ tmp ->
1760 getAmode dst `thenNat` \ amode ->
1761 getRegister src `thenNat` \ register ->
1763 code1 = amodeCode amode []
1764 dst__2 = amodeAddr amode
1765 code2 = registerCode register tmp []
1766 src__2 = registerName register tmp
1767 sz = primRepToSize pk
1768 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1772 assignFltCode pk dst src
1773 = getRegister dst `thenNat` \ register1 ->
1774 getRegister src `thenNat` \ register2 ->
1776 dst__2 = registerName register1 zeroh
1777 code = registerCode register2 dst__2
1778 src__2 = registerName register2 dst__2
1779 code__2 = if isFixed register2
1780 then code . mkSeqInstr (FMOV src__2 dst__2)
1785 #endif {- alpha_TARGET_ARCH -}
1786 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1787 #if i386_TARGET_ARCH
1790 assignFltCode pk (StInd pk_dst addr) src
1792 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1794 = getRegister src `thenNat` \ reg_src ->
1795 getRegister addr `thenNat` \ reg_addr ->
1796 getNewRegNCG pk `thenNat` \ tmp_src ->
1797 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1798 let r_src = registerName reg_src tmp_src
1799 c_src = registerCode reg_src tmp_src
1800 r_addr = registerName reg_addr tmp_addr
1801 c_addr = registerCode reg_addr tmp_addr
1802 sz = primRepToSize pk
1804 code = c_src `appOL`
1805 -- no need to preserve r_src across the addr computation,
1806 -- since r_src must be a float reg
1807 -- whilst r_addr is an int reg
1810 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1814 -- dst must be a (FP) register
1815 assignFltCode pk dst src
1816 = getRegister dst `thenNat` \ reg_dst ->
1817 getRegister src `thenNat` \ reg_src ->
1818 getNewRegNCG pk `thenNat` \ tmp ->
1820 r_dst = registerName reg_dst tmp
1821 c_dst = registerCode reg_dst tmp -- should be empty
1823 r_src = registerName reg_src r_dst
1824 c_src = registerCode reg_src r_dst
1826 code | isNilOL c_dst
1827 = if isFixed reg_src
1828 then c_src `snocOL` GMOV r_src r_dst
1831 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1837 #endif {- i386_TARGET_ARCH -}
1838 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1839 #if sparc_TARGET_ARCH
1841 assignFltCode pk (StInd _ dst) src
1842 = getNewRegNCG pk `thenNat` \ tmp1 ->
1843 getAmode dst `thenNat` \ amode ->
1844 getRegister src `thenNat` \ register ->
1846 sz = primRepToSize pk
1847 dst__2 = amodeAddr amode
1849 code1 = amodeCode amode []
1850 code2 = registerCode register tmp1 []
1852 src__2 = registerName register tmp1
1853 pk__2 = registerRep register
1854 sz__2 = primRepToSize pk__2
1856 code__2 = asmSeqThen [code1, code2] ++
1858 mkSeqInstr (ST sz src__2 dst__2)
1860 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1864 assignFltCode pk dst src
1865 = getRegister dst `thenNat` \ register1 ->
1866 getRegister src `thenNat` \ register2 ->
1868 pk__2 = registerRep register2
1869 sz__2 = primRepToSize pk__2
1871 getNewRegNCG pk__2 `thenNat` \ tmp ->
1873 sz = primRepToSize pk
1874 dst__2 = registerName register1 g0 -- must be Fixed
1877 reg__2 = if pk /= pk__2 then tmp else dst__2
1879 code = registerCode register2 reg__2
1881 src__2 = registerName register2 reg__2
1885 code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1886 else if isFixed register2 then
1887 code . mkSeqInstr (FMOV sz src__2 dst__2)
1893 #endif {- sparc_TARGET_ARCH -}
1896 %************************************************************************
1898 \subsection{Generating an unconditional branch}
1900 %************************************************************************
1902 We accept two types of targets: an immediate CLabel or a tree that
1903 gets evaluated into a register. Any CLabels which are AsmTemporaries
1904 are assumed to be in the local block of code, close enough for a
1905 branch instruction. Other CLabels are assumed to be far away.
1907 (If applicable) Do not fill the delay slots here; you will confuse the
1911 genJump :: StixTree{-the branch target-} -> NatM InstrBlock
1913 #if alpha_TARGET_ARCH
1915 genJump (StCLbl lbl)
1916 | isAsmTemp lbl = returnInstr (BR target)
1917 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1919 target = ImmCLbl lbl
1922 = getRegister tree `thenNat` \ register ->
1923 getNewRegNCG PtrRep `thenNat` \ tmp ->
1925 dst = registerName register pv
1926 code = registerCode register pv
1927 target = registerName register pv
1929 if isFixed register then
1930 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1932 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1934 #endif {- alpha_TARGET_ARCH -}
1935 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1936 #if i386_TARGET_ARCH
1938 genJump (StInd pk mem)
1939 = getAmode mem `thenNat` \ amode ->
1941 code = amodeCode amode
1942 target = amodeAddr amode
1944 returnNat (code `snocOL` JMP (OpAddr target))
1948 = returnNat (unitOL (JMP (OpImm target)))
1951 = getRegister tree `thenNat` \ register ->
1952 getNewRegNCG PtrRep `thenNat` \ tmp ->
1954 code = registerCode register tmp
1955 target = registerName register tmp
1957 returnNat (code `snocOL` JMP (OpReg target))
1960 target = case imm of Just x -> x
1962 #endif {- i386_TARGET_ARCH -}
1963 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1964 #if sparc_TARGET_ARCH
1966 genJump (StCLbl lbl)
1967 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1968 | otherwise = returnInstrs [CALL target 0 True, NOP]
1970 target = ImmCLbl lbl
1973 = getRegister tree `thenNat` \ register ->
1974 getNewRegNCG PtrRep `thenNat` \ tmp ->
1976 code = registerCode register tmp
1977 target = registerName register tmp
1979 returnSeq code [JMP (AddrRegReg target g0), NOP]
1981 #endif {- sparc_TARGET_ARCH -}
1984 %************************************************************************
1986 \subsection{Conditional jumps}
1988 %************************************************************************
1990 Conditional jumps are always to local labels, so we can use branch
1991 instructions. We peek at the arguments to decide what kind of
1994 ALPHA: For comparisons with 0, we're laughing, because we can just do
1995 the desired conditional branch.
1997 I386: First, we have to ensure that the condition
1998 codes are set according to the supplied comparison operation.
2000 SPARC: First, we have to ensure that the condition codes are set
2001 according to the supplied comparison operation. We generate slightly
2002 different code for floating point comparisons, because a floating
2003 point operation cannot directly precede a @BF@. We assume the worst
2004 and fill that slot with a @NOP@.
2006 SPARC: Do not fill the delay slots here; you will confuse the register
2011 :: CLabel -- the branch target
2012 -> StixTree -- the condition on which to branch
2015 #if alpha_TARGET_ARCH
2017 genCondJump lbl (StPrim op [x, StInt 0])
2018 = getRegister x `thenNat` \ register ->
2019 getNewRegNCG (registerRep register)
2022 code = registerCode register tmp
2023 value = registerName register tmp
2024 pk = registerRep register
2025 target = ImmCLbl lbl
2027 returnSeq code [BI (cmpOp op) value target]
2029 cmpOp CharGtOp = GTT
2031 cmpOp CharEqOp = EQQ
2033 cmpOp CharLtOp = LTT
2042 cmpOp WordGeOp = ALWAYS
2043 cmpOp WordEqOp = EQQ
2045 cmpOp WordLtOp = NEVER
2046 cmpOp WordLeOp = EQQ
2048 cmpOp AddrGeOp = ALWAYS
2049 cmpOp AddrEqOp = EQQ
2051 cmpOp AddrLtOp = NEVER
2052 cmpOp AddrLeOp = EQQ
2054 genCondJump lbl (StPrim op [x, StDouble 0.0])
2055 = getRegister x `thenNat` \ register ->
2056 getNewRegNCG (registerRep register)
2059 code = registerCode register tmp
2060 value = registerName register tmp
2061 pk = registerRep register
2062 target = ImmCLbl lbl
2064 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2066 cmpOp FloatGtOp = GTT
2067 cmpOp FloatGeOp = GE
2068 cmpOp FloatEqOp = EQQ
2069 cmpOp FloatNeOp = NE
2070 cmpOp FloatLtOp = LTT
2071 cmpOp FloatLeOp = LE
2072 cmpOp DoubleGtOp = GTT
2073 cmpOp DoubleGeOp = GE
2074 cmpOp DoubleEqOp = EQQ
2075 cmpOp DoubleNeOp = NE
2076 cmpOp DoubleLtOp = LTT
2077 cmpOp DoubleLeOp = LE
2079 genCondJump lbl (StPrim op [x, y])
2081 = trivialFCode pr instr x y `thenNat` \ register ->
2082 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2084 code = registerCode register tmp
2085 result = registerName register tmp
2086 target = ImmCLbl lbl
2088 returnNat (code . mkSeqInstr (BF cond result target))
2090 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2092 fltCmpOp op = case op of
2106 (instr, cond) = case op of
2107 FloatGtOp -> (FCMP TF LE, EQQ)
2108 FloatGeOp -> (FCMP TF LTT, EQQ)
2109 FloatEqOp -> (FCMP TF EQQ, NE)
2110 FloatNeOp -> (FCMP TF EQQ, EQQ)
2111 FloatLtOp -> (FCMP TF LTT, NE)
2112 FloatLeOp -> (FCMP TF LE, NE)
2113 DoubleGtOp -> (FCMP TF LE, EQQ)
2114 DoubleGeOp -> (FCMP TF LTT, EQQ)
2115 DoubleEqOp -> (FCMP TF EQQ, NE)
2116 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2117 DoubleLtOp -> (FCMP TF LTT, NE)
2118 DoubleLeOp -> (FCMP TF LE, NE)
2120 genCondJump lbl (StPrim op [x, y])
2121 = trivialCode instr x y `thenNat` \ register ->
2122 getNewRegNCG IntRep `thenNat` \ tmp ->
2124 code = registerCode register tmp
2125 result = registerName register tmp
2126 target = ImmCLbl lbl
2128 returnNat (code . mkSeqInstr (BI cond result target))
2130 (instr, cond) = case op of
2131 CharGtOp -> (CMP LE, EQQ)
2132 CharGeOp -> (CMP LTT, EQQ)
2133 CharEqOp -> (CMP EQQ, NE)
2134 CharNeOp -> (CMP EQQ, EQQ)
2135 CharLtOp -> (CMP LTT, NE)
2136 CharLeOp -> (CMP LE, NE)
2137 IntGtOp -> (CMP LE, EQQ)
2138 IntGeOp -> (CMP LTT, EQQ)
2139 IntEqOp -> (CMP EQQ, NE)
2140 IntNeOp -> (CMP EQQ, EQQ)
2141 IntLtOp -> (CMP LTT, NE)
2142 IntLeOp -> (CMP LE, NE)
2143 WordGtOp -> (CMP ULE, EQQ)
2144 WordGeOp -> (CMP ULT, EQQ)
2145 WordEqOp -> (CMP EQQ, NE)
2146 WordNeOp -> (CMP EQQ, EQQ)
2147 WordLtOp -> (CMP ULT, NE)
2148 WordLeOp -> (CMP ULE, NE)
2149 AddrGtOp -> (CMP ULE, EQQ)
2150 AddrGeOp -> (CMP ULT, EQQ)
2151 AddrEqOp -> (CMP EQQ, NE)
2152 AddrNeOp -> (CMP EQQ, EQQ)
2153 AddrLtOp -> (CMP ULT, NE)
2154 AddrLeOp -> (CMP ULE, NE)
2156 #endif {- alpha_TARGET_ARCH -}
2157 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2158 #if i386_TARGET_ARCH
2160 genCondJump lbl bool
2161 = getCondCode bool `thenNat` \ condition ->
2163 code = condCode condition
2164 cond = condName condition
2165 target = ImmCLbl lbl
2167 returnNat (code `snocOL` JXX cond lbl)
2169 #endif {- i386_TARGET_ARCH -}
2170 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2171 #if sparc_TARGET_ARCH
2173 genCondJump lbl bool
2174 = getCondCode bool `thenNat` \ condition ->
2176 code = condCode condition
2177 cond = condName condition
2178 target = ImmCLbl lbl
2181 if condFloat condition then
2182 [NOP, BF cond False target, NOP]
2184 [BI cond False target, NOP]
2187 #endif {- sparc_TARGET_ARCH -}
2190 %************************************************************************
2192 \subsection{Generating C calls}
2194 %************************************************************************
2196 Now the biggest nightmare---calls. Most of the nastiness is buried in
2197 @get_arg@, which moves the arguments to the correct registers/stack
2198 locations. Apart from that, the code is easy.
2200 (If applicable) Do not fill the delay slots here; you will confuse the
2205 :: FAST_STRING -- function to call
2207 -> PrimRep -- type of the result
2208 -> [StixTree] -- arguments (of mixed type)
2211 #if alpha_TARGET_ARCH
2213 genCCall fn cconv kind args
2214 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2215 `thenNat` \ ((unused,_), argCode) ->
2217 nRegs = length allArgRegs - length unused
2218 code = asmSeqThen (map ($ []) argCode)
2221 LDA pv (AddrImm (ImmLab (ptext fn))),
2222 JSR ra (AddrReg pv) nRegs,
2223 LDGP gp (AddrReg ra)]
2225 ------------------------
2226 {- Try to get a value into a specific register (or registers) for
2227 a call. The first 6 arguments go into the appropriate
2228 argument register (separate registers for integer and floating
2229 point arguments, but used in lock-step), and the remaining
2230 arguments are dumped to the stack, beginning at 0(sp). Our
2231 first argument is a pair of the list of remaining argument
2232 registers to be assigned for this call and the next stack
2233 offset to use for overflowing arguments. This way,
2234 @get_Arg@ can be applied to all of a call's arguments using
2238 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2239 -> StixTree -- Current argument
2240 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2242 -- We have to use up all of our argument registers first...
2244 get_arg ((iDst,fDst):dsts, offset) arg
2245 = getRegister arg `thenNat` \ register ->
2247 reg = if isFloatingRep pk then fDst else iDst
2248 code = registerCode register reg
2249 src = registerName register reg
2250 pk = registerRep register
2253 if isFloatingRep pk then
2254 ((dsts, offset), if isFixed register then
2255 code . mkSeqInstr (FMOV src fDst)
2258 ((dsts, offset), if isFixed register then
2259 code . mkSeqInstr (OR src (RIReg src) iDst)
2262 -- Once we have run out of argument registers, we move to the
2265 get_arg ([], offset) arg
2266 = getRegister arg `thenNat` \ register ->
2267 getNewRegNCG (registerRep register)
2270 code = registerCode register tmp
2271 src = registerName register tmp
2272 pk = registerRep register
2273 sz = primRepToSize pk
2275 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2277 #endif {- alpha_TARGET_ARCH -}
2278 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2279 #if i386_TARGET_ARCH
2281 genCCall fn cconv kind [StInt i]
2282 | fn == SLIT ("PerformGC_wrapper")
2284 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2285 CALL (ImmLit (ptext (if underscorePrefix
2286 then (SLIT ("_PerformGC_wrapper"))
2287 else (SLIT ("PerformGC_wrapper")))))
2293 genCCall fn cconv kind args
2294 = mapNat get_call_arg
2295 (reverse args) `thenNat` \ sizes_n_codes ->
2296 getDeltaNat `thenNat` \ delta ->
2297 let (sizes, codes) = unzip sizes_n_codes
2298 tot_arg_size = sum sizes
2299 code2 = concatOL codes
2302 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2303 DELTA (delta + tot_arg_size)
2306 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2307 returnNat (code2 `appOL` call)
2310 -- function names that begin with '.' are assumed to be special
2311 -- internally generated names like '.mul,' which don't get an
2312 -- underscore prefix
2313 -- ToDo:needed (WDP 96/03) ???
2314 fn__2 = case (_HEAD_ fn) of
2315 '.' -> ImmLit (ptext fn)
2316 _ -> ImmLab (ptext fn)
2323 get_call_arg :: StixTree{-current argument-}
2324 -> NatM (Int, InstrBlock) -- argsz, code
2327 = get_op arg `thenNat` \ (code, reg, sz) ->
2328 getDeltaNat `thenNat` \ delta ->
2329 arg_size sz `bind` \ size ->
2330 setDeltaNat (delta-size) `thenNat` \ _ ->
2331 if (case sz of DF -> True; F -> True; _ -> False)
2332 then returnNat (size,
2334 toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
2336 GST DF reg (AddrBaseIndex (Just esp)
2340 else returnNat (size,
2342 PUSH L (OpReg reg) `snocOL`
2348 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2351 = getRegister op `thenNat` \ register ->
2352 getNewRegNCG (registerRep register)
2355 code = registerCode register tmp
2356 reg = registerName register tmp
2357 pk = registerRep register
2358 sz = primRepToSize pk
2360 returnNat (code, reg, sz)
2362 #endif {- i386_TARGET_ARCH -}
2363 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2364 #if sparc_TARGET_ARCH
2366 genCCall fn cconv kind args
2367 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2368 `thenNat` \ ((unused,_), argCode) ->
2370 nRegs = length allArgRegs - length unused
2371 call = CALL fn__2 nRegs False
2372 code = asmSeqThen (map ($ []) argCode)
2374 returnSeq code [call, NOP]
2376 -- function names that begin with '.' are assumed to be special
2377 -- internally generated names like '.mul,' which don't get an
2378 -- underscore prefix
2379 -- ToDo:needed (WDP 96/03) ???
2380 fn__2 = case (_HEAD_ fn) of
2381 '.' -> ImmLit (ptext fn)
2382 _ -> ImmLab (ptext fn)
2384 ------------------------------------
2385 {- Try to get a value into a specific register (or registers) for
2386 a call. The SPARC calling convention is an absolute
2387 nightmare. The first 6x32 bits of arguments are mapped into
2388 %o0 through %o5, and the remaining arguments are dumped to the
2389 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2390 first argument is a pair of the list of remaining argument
2391 registers to be assigned for this call and the next stack
2392 offset to use for overflowing arguments. This way,
2393 @get_arg@ can be applied to all of a call's arguments using
2397 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2398 -> StixTree -- Current argument
2399 -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2401 -- We have to use up all of our argument registers first...
2403 get_arg (dst:dsts, offset) arg
2404 = getRegister arg `thenNat` \ register ->
2405 getNewRegNCG (registerRep register)
2408 reg = if isFloatingRep pk then tmp else dst
2409 code = registerCode register reg
2410 src = registerName register reg
2411 pk = registerRep register
2413 returnNat (case pk of
2416 [] -> (([], offset + 1), code . mkSeqInstrs [
2417 -- conveniently put the second part in the right stack
2418 -- location, and load the first part into %o5
2419 ST DF src (spRel (offset - 1)),
2420 LD W (spRel (offset - 1)) dst])
2421 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2422 ST DF src (spRel (-2)),
2423 LD W (spRel (-2)) dst,
2424 LD W (spRel (-1)) dst__2])
2425 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2426 ST F src (spRel (-2)),
2427 LD W (spRel (-2)) dst])
2428 _ -> ((dsts, offset), if isFixed register then
2429 code . mkSeqInstr (OR False g0 (RIReg src) dst)
2432 -- Once we have run out of argument registers, we move to the
2435 get_arg ([], offset) arg
2436 = getRegister arg `thenNat` \ register ->
2437 getNewRegNCG (registerRep register)
2440 code = registerCode register tmp
2441 src = registerName register tmp
2442 pk = registerRep register
2443 sz = primRepToSize pk
2444 words = if pk == DoubleRep then 2 else 1
2446 returnNat (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2448 #endif {- sparc_TARGET_ARCH -}
2451 %************************************************************************
2453 \subsection{Support bits}
2455 %************************************************************************
2457 %************************************************************************
2459 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2461 %************************************************************************
2463 Turn those condition codes into integers now (when they appear on
2464 the right hand side of an assignment).
2466 (If applicable) Do not fill the delay slots here; you will confuse the
2470 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2472 #if alpha_TARGET_ARCH
2473 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2474 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2475 #endif {- alpha_TARGET_ARCH -}
2477 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2478 #if i386_TARGET_ARCH
2481 = condIntCode cond x y `thenNat` \ condition ->
2482 getNewRegNCG IntRep `thenNat` \ tmp ->
2484 code = condCode condition
2485 cond = condName condition
2486 code__2 dst = code `appOL` toOL [
2487 SETCC cond (OpReg tmp),
2488 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2489 MOV L (OpReg tmp) (OpReg dst)]
2491 returnNat (Any IntRep code__2)
2494 = getNatLabelNCG `thenNat` \ lbl1 ->
2495 getNatLabelNCG `thenNat` \ lbl2 ->
2496 condFltCode cond x y `thenNat` \ condition ->
2498 code = condCode condition
2499 cond = condName condition
2500 code__2 dst = code `appOL` toOL [
2502 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2505 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2508 returnNat (Any IntRep code__2)
2510 #endif {- i386_TARGET_ARCH -}
2511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2512 #if sparc_TARGET_ARCH
2514 condIntReg EQQ x (StInt 0)
2515 = getRegister x `thenNat` \ register ->
2516 getNewRegNCG IntRep `thenNat` \ tmp ->
2518 code = registerCode register tmp
2519 src = registerName register tmp
2520 code__2 dst = code . mkSeqInstrs [
2521 SUB False True g0 (RIReg src) g0,
2522 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2524 returnNat (Any IntRep code__2)
2527 = getRegister x `thenNat` \ register1 ->
2528 getRegister y `thenNat` \ register2 ->
2529 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2530 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2532 code1 = registerCode register1 tmp1 []
2533 src1 = registerName register1 tmp1
2534 code2 = registerCode register2 tmp2 []
2535 src2 = registerName register2 tmp2
2536 code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
2537 XOR False src1 (RIReg src2) dst,
2538 SUB False True g0 (RIReg dst) g0,
2539 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2541 returnNat (Any IntRep code__2)
2543 condIntReg NE x (StInt 0)
2544 = getRegister x `thenNat` \ register ->
2545 getNewRegNCG IntRep `thenNat` \ tmp ->
2547 code = registerCode register tmp
2548 src = registerName register tmp
2549 code__2 dst = code . mkSeqInstrs [
2550 SUB False True g0 (RIReg src) g0,
2551 ADD True False g0 (RIImm (ImmInt 0)) dst]
2553 returnNat (Any IntRep code__2)
2556 = getRegister x `thenNat` \ register1 ->
2557 getRegister y `thenNat` \ register2 ->
2558 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2559 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2561 code1 = registerCode register1 tmp1 []
2562 src1 = registerName register1 tmp1
2563 code2 = registerCode register2 tmp2 []
2564 src2 = registerName register2 tmp2
2565 code__2 dst = asmSeqThen [code1, code2] . mkSeqInstrs [
2566 XOR False src1 (RIReg src2) dst,
2567 SUB False True g0 (RIReg dst) g0,
2568 ADD True False g0 (RIImm (ImmInt 0)) dst]
2570 returnNat (Any IntRep code__2)
2573 = getNatLabelNCG `thenNat` \ lbl1 ->
2574 getNatLabelNCG `thenNat` \ lbl2 ->
2575 condIntCode cond x y `thenNat` \ condition ->
2577 code = condCode condition
2578 cond = condName condition
2579 code__2 dst = code . mkSeqInstrs [
2580 BI cond False (ImmCLbl lbl1), NOP,
2581 OR False g0 (RIImm (ImmInt 0)) dst,
2582 BI ALWAYS False (ImmCLbl lbl2), NOP,
2584 OR False g0 (RIImm (ImmInt 1)) dst,
2587 returnNat (Any IntRep code__2)
2590 = getNatLabelNCG `thenNat` \ lbl1 ->
2591 getNatLabelNCG `thenNat` \ lbl2 ->
2592 condFltCode cond x y `thenNat` \ condition ->
2594 code = condCode condition
2595 cond = condName condition
2596 code__2 dst = code . mkSeqInstrs [
2598 BF cond False (ImmCLbl lbl1), NOP,
2599 OR False g0 (RIImm (ImmInt 0)) dst,
2600 BI ALWAYS False (ImmCLbl lbl2), NOP,
2602 OR False g0 (RIImm (ImmInt 1)) dst,
2605 returnNat (Any IntRep code__2)
2607 #endif {- sparc_TARGET_ARCH -}
2610 %************************************************************************
2612 \subsubsection{@trivial*Code@: deal with trivial instructions}
2614 %************************************************************************
2616 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2617 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2618 for constants on the right hand side, because that's where the generic
2619 optimizer will have put them.
2621 Similarly, for unary instructions, we don't have to worry about
2622 matching an StInt as the argument, because genericOpt will already
2623 have handled the constant-folding.
2627 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2628 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2629 -> Maybe (Operand -> Operand -> Instr)
2630 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2632 -> StixTree -> StixTree -- the two arguments
2637 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2638 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2639 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2641 -> StixTree -> StixTree -- the two arguments
2645 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2646 ,IF_ARCH_i386 ((Operand -> Instr)
2647 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2649 -> StixTree -- the one argument
2654 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2655 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2656 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2658 -> StixTree -- the one argument
2661 #if alpha_TARGET_ARCH
2663 trivialCode instr x (StInt y)
2665 = getRegister x `thenNat` \ register ->
2666 getNewRegNCG IntRep `thenNat` \ tmp ->
2668 code = registerCode register tmp
2669 src1 = registerName register tmp
2670 src2 = ImmInt (fromInteger y)
2671 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2673 returnNat (Any IntRep code__2)
2675 trivialCode instr x y
2676 = getRegister x `thenNat` \ register1 ->
2677 getRegister y `thenNat` \ register2 ->
2678 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2679 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2681 code1 = registerCode register1 tmp1 []
2682 src1 = registerName register1 tmp1
2683 code2 = registerCode register2 tmp2 []
2684 src2 = registerName register2 tmp2
2685 code__2 dst = asmSeqThen [code1, code2] .
2686 mkSeqInstr (instr src1 (RIReg src2) dst)
2688 returnNat (Any IntRep code__2)
2691 trivialUCode instr x
2692 = getRegister x `thenNat` \ register ->
2693 getNewRegNCG IntRep `thenNat` \ tmp ->
2695 code = registerCode register tmp
2696 src = registerName register tmp
2697 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2699 returnNat (Any IntRep code__2)
2702 trivialFCode _ instr x y
2703 = getRegister x `thenNat` \ register1 ->
2704 getRegister y `thenNat` \ register2 ->
2705 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2706 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2708 code1 = registerCode register1 tmp1
2709 src1 = registerName register1 tmp1
2711 code2 = registerCode register2 tmp2
2712 src2 = registerName register2 tmp2
2714 code__2 dst = asmSeqThen [code1 [], code2 []] .
2715 mkSeqInstr (instr src1 src2 dst)
2717 returnNat (Any DoubleRep code__2)
2719 trivialUFCode _ instr x
2720 = getRegister x `thenNat` \ register ->
2721 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2723 code = registerCode register tmp
2724 src = registerName register tmp
2725 code__2 dst = code . mkSeqInstr (instr src dst)
2727 returnNat (Any DoubleRep code__2)
2729 #endif {- alpha_TARGET_ARCH -}
2730 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2731 #if i386_TARGET_ARCH
2733 The Rules of the Game are:
2735 * You cannot assume anything about the destination register dst;
2736 it may be anything, including a fixed reg.
2738 * You may compute an operand into a fixed reg, but you may not
2739 subsequently change the contents of that fixed reg. If you
2740 want to do so, first copy the value either to a temporary
2741 or into dst. You are free to modify dst even if it happens
2742 to be a fixed reg -- that's not your problem.
2744 * You cannot assume that a fixed reg will stay live over an
2745 arbitrary computation. The same applies to the dst reg.
2747 * Temporary regs obtained from getNewRegNCG are distinct from
2748 each other and from all other regs, and stay live over
2749 arbitrary computations.
2753 trivialCode instr maybe_revinstr a b
2756 = getRegister a `thenNat` \ rega ->
2759 then registerCode rega dst `bind` \ code_a ->
2761 instr (OpImm imm_b) (OpReg dst)
2762 else registerCodeF rega `bind` \ code_a ->
2763 registerNameF rega `bind` \ r_a ->
2765 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2766 instr (OpImm imm_b) (OpReg dst)
2768 returnNat (Any IntRep mkcode)
2771 = getRegister b `thenNat` \ regb ->
2772 getNewRegNCG IntRep `thenNat` \ tmp ->
2773 let revinstr_avail = maybeToBool maybe_revinstr
2774 revinstr = case maybe_revinstr of Just ri -> ri
2778 then registerCode regb dst `bind` \ code_b ->
2780 revinstr (OpImm imm_a) (OpReg dst)
2781 else registerCodeF regb `bind` \ code_b ->
2782 registerNameF regb `bind` \ r_b ->
2784 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2785 revinstr (OpImm imm_a) (OpReg dst)
2789 then registerCode regb tmp `bind` \ code_b ->
2791 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2792 instr (OpReg tmp) (OpReg dst)
2793 else registerCodeF regb `bind` \ code_b ->
2794 registerNameF regb `bind` \ r_b ->
2796 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2797 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2798 instr (OpReg tmp) (OpReg dst)
2800 returnNat (Any IntRep mkcode)
2803 = getRegister a `thenNat` \ rega ->
2804 getRegister b `thenNat` \ regb ->
2805 getNewRegNCG IntRep `thenNat` \ tmp ->
2807 = case (isAny rega, isAny regb) of
2809 -> registerCode regb tmp `bind` \ code_b ->
2810 registerCode rega dst `bind` \ code_a ->
2813 instr (OpReg tmp) (OpReg dst)
2815 -> registerCode rega tmp `bind` \ code_a ->
2816 registerCodeF regb `bind` \ code_b ->
2817 registerNameF regb `bind` \ r_b ->
2820 instr (OpReg r_b) (OpReg tmp) `snocOL`
2821 MOV L (OpReg tmp) (OpReg dst)
2823 -> registerCode regb tmp `bind` \ code_b ->
2824 registerCodeF rega `bind` \ code_a ->
2825 registerNameF rega `bind` \ r_a ->
2828 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2829 instr (OpReg tmp) (OpReg dst)
2831 -> registerCodeF rega `bind` \ code_a ->
2832 registerNameF rega `bind` \ r_a ->
2833 registerCodeF regb `bind` \ code_b ->
2834 registerNameF regb `bind` \ r_b ->
2836 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2838 instr (OpReg r_b) (OpReg tmp) `snocOL`
2839 MOV L (OpReg tmp) (OpReg dst)
2841 returnNat (Any IntRep mkcode)
2844 maybe_imm_a = maybeImm a
2845 is_imm_a = maybeToBool maybe_imm_a
2846 imm_a = case maybe_imm_a of Just imm -> imm
2848 maybe_imm_b = maybeImm b
2849 is_imm_b = maybeToBool maybe_imm_b
2850 imm_b = case maybe_imm_b of Just imm -> imm
2854 trivialUCode instr x
2855 = getRegister x `thenNat` \ register ->
2857 code__2 dst = let code = registerCode register dst
2858 src = registerName register dst
2860 if isFixed register && dst /= src
2861 then toOL [MOV L (OpReg src) (OpReg dst),
2863 else unitOL (instr (OpReg src))
2865 returnNat (Any IntRep code__2)
2868 trivialFCode pk instr x y
2869 = getRegister x `thenNat` \ register1 ->
2870 getRegister y `thenNat` \ register2 ->
2871 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2872 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2874 code1 = registerCode register1 tmp1
2875 src1 = registerName register1 tmp1
2877 code2 = registerCode register2 tmp2
2878 src2 = registerName register2 tmp2
2881 -- treat the common case specially: both operands in
2883 | isAny register1 && isAny register2
2886 instr (primRepToSize pk) src1 src2 dst
2888 -- be paranoid (and inefficient)
2890 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2892 instr (primRepToSize pk) tmp1 src2 dst
2894 returnNat (Any DoubleRep code__2)
2898 trivialUFCode pk instr x
2899 = getRegister x `thenNat` \ register ->
2900 getNewRegNCG pk `thenNat` \ tmp ->
2902 code = registerCode register tmp
2903 src = registerName register tmp
2904 code__2 dst = code `snocOL` instr src dst
2906 returnNat (Any pk code__2)
2908 #endif {- i386_TARGET_ARCH -}
2909 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2910 #if sparc_TARGET_ARCH
2912 trivialCode instr x (StInt y)
2914 = getRegister x `thenNat` \ register ->
2915 getNewRegNCG IntRep `thenNat` \ tmp ->
2917 code = registerCode register tmp
2918 src1 = registerName register tmp
2919 src2 = ImmInt (fromInteger y)
2920 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2922 returnNat (Any IntRep code__2)
2924 trivialCode instr x y
2925 = getRegister x `thenNat` \ register1 ->
2926 getRegister y `thenNat` \ register2 ->
2927 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2928 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2930 code1 = registerCode register1 tmp1 []
2931 src1 = registerName register1 tmp1
2932 code2 = registerCode register2 tmp2 []
2933 src2 = registerName register2 tmp2
2934 code__2 dst = asmSeqThen [code1, code2] .
2935 mkSeqInstr (instr src1 (RIReg src2) dst)
2937 returnNat (Any IntRep code__2)
2940 trivialFCode pk instr x y
2941 = getRegister x `thenNat` \ register1 ->
2942 getRegister y `thenNat` \ register2 ->
2943 getNewRegNCG (registerRep register1)
2945 getNewRegNCG (registerRep register2)
2947 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2949 promote x = asmInstr (FxTOy F DF x tmp)
2951 pk1 = registerRep register1
2952 code1 = registerCode register1 tmp1
2953 src1 = registerName register1 tmp1
2955 pk2 = registerRep register2
2956 code2 = registerCode register2 tmp2
2957 src2 = registerName register2 tmp2
2961 asmSeqThen [code1 [], code2 []] .
2962 mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2963 else if pk1 == FloatRep then
2964 asmSeqThen [code1 (promote src1), code2 []] .
2965 mkSeqInstr (instr DF tmp src2 dst)
2967 asmSeqThen [code1 [], code2 (promote src2)] .
2968 mkSeqInstr (instr DF src1 tmp dst)
2970 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2973 trivialUCode instr x
2974 = getRegister x `thenNat` \ register ->
2975 getNewRegNCG IntRep `thenNat` \ tmp ->
2977 code = registerCode register tmp
2978 src = registerName register tmp
2979 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2981 returnNat (Any IntRep code__2)
2984 trivialUFCode pk instr x
2985 = getRegister x `thenNat` \ register ->
2986 getNewRegNCG pk `thenNat` \ tmp ->
2988 code = registerCode register tmp
2989 src = registerName register tmp
2990 code__2 dst = code . mkSeqInstr (instr src dst)
2992 returnNat (Any pk code__2)
2994 #endif {- sparc_TARGET_ARCH -}
2997 %************************************************************************
2999 \subsubsection{Coercing to/from integer/floating-point...}
3001 %************************************************************************
3003 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3004 to be generated. Here we just change the type on the Register passed
3005 on up. The code is machine-independent.
3007 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3008 conversions. We have to store temporaries in memory to move
3009 between the integer and the floating point register sets.
3012 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3013 coerceFltCode :: StixTree -> NatM Register
3015 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3016 coerceFP2Int :: StixTree -> NatM Register
3019 = getRegister x `thenNat` \ register ->
3022 Fixed _ reg code -> Fixed pk reg code
3023 Any _ code -> Any pk code
3028 = getRegister x `thenNat` \ register ->
3031 Fixed _ reg code -> Fixed DoubleRep reg code
3032 Any _ code -> Any DoubleRep code
3037 #if alpha_TARGET_ARCH
3040 = getRegister x `thenNat` \ register ->
3041 getNewRegNCG IntRep `thenNat` \ reg ->
3043 code = registerCode register reg
3044 src = registerName register reg
3046 code__2 dst = code . mkSeqInstrs [
3048 LD TF dst (spRel 0),
3051 returnNat (Any DoubleRep code__2)
3055 = getRegister x `thenNat` \ register ->
3056 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3058 code = registerCode register tmp
3059 src = registerName register tmp
3061 code__2 dst = code . mkSeqInstrs [
3063 ST TF tmp (spRel 0),
3066 returnNat (Any IntRep code__2)
3068 #endif {- alpha_TARGET_ARCH -}
3069 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3070 #if i386_TARGET_ARCH
3073 = getRegister x `thenNat` \ register ->
3074 getNewRegNCG IntRep `thenNat` \ reg ->
3076 code = registerCode register reg
3077 src = registerName register reg
3078 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3079 code__2 dst = code `snocOL` opc src dst
3081 returnNat (Any pk code__2)
3085 = getRegister x `thenNat` \ register ->
3086 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3088 code = registerCode register tmp
3089 src = registerName register tmp
3090 pk = registerRep register
3092 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3093 code__2 dst = code `snocOL` opc src dst
3095 returnNat (Any IntRep code__2)
3097 #endif {- i386_TARGET_ARCH -}
3098 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3099 #if sparc_TARGET_ARCH
3102 = getRegister x `thenNat` \ register ->
3103 getNewRegNCG IntRep `thenNat` \ reg ->
3105 code = registerCode register reg
3106 src = registerName register reg
3108 code__2 dst = code . mkSeqInstrs [
3109 ST W src (spRel (-2)),
3110 LD W (spRel (-2)) dst,
3111 FxTOy W (primRepToSize pk) dst dst]
3113 returnNat (Any pk code__2)
3117 = getRegister x `thenNat` \ register ->
3118 getNewRegNCG IntRep `thenNat` \ reg ->
3119 getNewRegNCG FloatRep `thenNat` \ tmp ->
3121 code = registerCode register reg
3122 src = registerName register reg
3123 pk = registerRep register
3125 code__2 dst = code . mkSeqInstrs [
3126 FxTOy (primRepToSize pk) W src tmp,
3127 ST W tmp (spRel (-2)),
3128 LD W (spRel (-2)) dst]
3130 returnNat (Any IntRep code__2)
3132 #endif {- sparc_TARGET_ARCH -}
3135 %************************************************************************
3137 \subsubsection{Coercing integer to @Char@...}
3139 %************************************************************************
3141 Integer to character conversion. Where applicable, we try to do this
3142 in one step if the original object is in memory.
3145 chrCode :: StixTree -> NatM Register
3147 #if alpha_TARGET_ARCH
3150 = getRegister x `thenNat` \ register ->
3151 getNewRegNCG IntRep `thenNat` \ reg ->
3153 code = registerCode register reg
3154 src = registerName register reg
3155 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3157 returnNat (Any IntRep code__2)
3159 #endif {- alpha_TARGET_ARCH -}
3160 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3161 #if i386_TARGET_ARCH
3164 = getRegister x `thenNat` \ register ->
3167 code = registerCode register dst
3168 src = registerName register dst
3170 if isFixed register && src /= dst
3171 then toOL [MOV L (OpReg src) (OpReg dst),
3172 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3173 else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3175 returnNat (Any IntRep code__2)
3177 #endif {- i386_TARGET_ARCH -}
3178 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3179 #if sparc_TARGET_ARCH
3181 chrCode (StInd pk mem)
3182 = getAmode mem `thenNat` \ amode ->
3184 code = amodeCode amode
3185 src = amodeAddr amode
3186 src_off = addrOffset src 3
3187 src__2 = case src_off of Just x -> x
3188 code__2 dst = if maybeToBool src_off then
3189 code . mkSeqInstr (LD BU src__2 dst)
3191 code . mkSeqInstrs [
3192 LD (primRepToSize pk) src dst,
3193 AND False dst (RIImm (ImmInt 255)) dst]
3195 returnNat (Any pk code__2)
3198 = getRegister x `thenNat` \ register ->
3199 getNewRegNCG IntRep `thenNat` \ reg ->
3201 code = registerCode register reg
3202 src = registerName register reg
3203 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3205 returnNat (Any IntRep code__2)
3207 #endif {- sparc_TARGET_ARCH -}