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 pprStixTree, ppStixReg,
31 NatM, thenNat, returnNat, mapNat,
32 mapAndUnzipNat, mapAccumLNat,
33 getDeltaNat, setDeltaNat
36 import CmdLineOpts ( opt_Static )
42 @InstrBlock@s are the insn sequences generated by the insn selectors.
43 They are really trees of insns to facilitate fast appending, where a
44 left-to-right traversal (pre-order?) yields the insns in the correct
49 type InstrBlock = OrdList Instr
55 Code extractor for an entire stix tree---stix statement level.
58 stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock
60 stmt2Instrs stmt = case stmt of
61 StComment s -> returnNat (unitOL (COMMENT s))
62 StSegment seg -> returnNat (unitOL (SEGMENT seg))
64 StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
66 StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
69 StLabel lab -> returnNat (unitOL (LABEL lab))
71 StJump arg -> genJump (derefDLL arg)
72 StCondJump lab arg -> genCondJump lab (derefDLL arg)
74 -- A call returning void, ie one done for its side-effects
75 StCall fn cconv VoidRep args -> genCCall fn
76 cconv VoidRep (map derefDLL args)
79 | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
80 | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src)
83 -- When falling through on the Alpha, we still have to load pv
84 -- with the address of the next routine, so that it can load gp.
85 -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
89 -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
90 returnNat (DATA (primRepToSize kind) imms
91 `consOL` concatOL codes)
93 getData :: StixTree -> NatM (InstrBlock, Imm)
95 getData (StInt i) = returnNat (nilOL, ImmInteger i)
96 getData (StDouble d) = returnNat (nilOL, ImmDouble d)
97 getData (StFloat d) = returnNat (nilOL, ImmFloat d)
98 getData (StCLbl l) = returnNat (nilOL, ImmCLbl l)
99 getData (StString s) =
100 getNatLabelNCG `thenNat` \ lbl ->
101 returnNat (toOL [LABEL lbl,
102 ASCII True (_UNPK_ s)],
104 -- the linker can handle simple arithmetic...
105 getData (StIndex rep (StCLbl lbl) (StInt off)) =
107 ImmIndex lbl (fromInteger (off * sizeOf rep)))
109 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
110 -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because
111 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
113 derefDLL :: StixTree -> StixTree
115 | opt_Static -- short out the entire deal if not doing DLLs
122 StCLbl lbl -> if labelDynamic lbl
123 then StInd PtrRep (StCLbl lbl)
125 -- all the rest are boring
126 StIndex pk base offset -> StIndex pk (qq base) (qq offset)
127 StPrim pk args -> StPrim pk (map qq args)
128 StInd pk addr -> StInd pk (qq addr)
129 StCall who cc pk args -> StCall who cc pk (map qq args)
136 _ -> pprPanic "derefDLL: unhandled case"
140 %************************************************************************
142 \subsection{General things for putting together code sequences}
144 %************************************************************************
147 mangleIndexTree :: StixTree -> StixTree
149 mangleIndexTree (StIndex pk base (StInt i))
150 = StPrim IntAddOp [base, off]
152 off = StInt (i * sizeOf pk)
154 mangleIndexTree (StIndex pk base off)
158 in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
159 if s == 0 then off else StPrim SllOp [off, StInt s]
162 shift DoubleRep = 3::Integer
163 shift CharRep = 0::Integer
164 shift _ = IF_ARCH_alpha(3,2)
168 maybeImm :: StixTree -> Maybe Imm
172 maybeImm (StIndex rep (StCLbl l) (StInt off))
173 = Just (ImmIndex l (fromInteger (off * sizeOf rep)))
175 | i >= toInteger minInt && i <= toInteger maxInt
176 = Just (ImmInt (fromInteger i))
178 = Just (ImmInteger i)
183 %************************************************************************
185 \subsection{The @Register@ type}
187 %************************************************************************
189 @Register@s passed up the tree. If the stix code forces the register
190 to live in a pre-decided machine register, it comes out as @Fixed@;
191 otherwise, it comes out as @Any@, and the parent can decide which
192 register to put it in.
196 = Fixed PrimRep Reg InstrBlock
197 | Any PrimRep (Reg -> InstrBlock)
199 registerCode :: Register -> Reg -> InstrBlock
200 registerCode (Fixed _ _ code) reg = code
201 registerCode (Any _ code) reg = code reg
203 registerCodeF (Fixed _ _ code) = code
204 registerCodeF (Any _ _) = pprPanic "registerCodeF" empty
206 registerCodeA (Any _ code) = code
207 registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty
209 registerName :: Register -> Reg -> Reg
210 registerName (Fixed _ reg _) _ = reg
211 registerName (Any _ _) reg = reg
213 registerNameF (Fixed _ reg _) = reg
214 registerNameF (Any _ _) = pprPanic "registerNameF" empty
216 registerRep :: Register -> PrimRep
217 registerRep (Fixed pk _ _) = pk
218 registerRep (Any pk _) = pk
220 {-# INLINE registerCode #-}
221 {-# INLINE registerCodeF #-}
222 {-# INLINE registerName #-}
223 {-# INLINE registerNameF #-}
224 {-# INLINE registerRep #-}
225 {-# INLINE isFixed #-}
228 isFixed, isAny :: Register -> Bool
229 isFixed (Fixed _ _ _) = True
230 isFixed (Any _ _) = False
232 isAny = not . isFixed
235 Generate code to get a subtree into a @Register@:
237 getRegister :: StixTree -> NatM Register
239 getRegister (StReg (StixMagicId stgreg))
240 = case (magicIdRegMaybe stgreg) of
241 Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
244 getRegister (StReg (StixTemp u pk))
245 = returnNat (Fixed pk (mkVReg u pk) nilOL)
247 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
249 getRegister (StCall fn cconv kind args)
250 = genCCall fn cconv kind args `thenNat` \ call ->
251 returnNat (Fixed kind reg call)
253 reg = if isFloatingRep kind
254 then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
255 else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
257 getRegister (StString s)
258 = getNatLabelNCG `thenNat` \ lbl ->
260 imm_lbl = ImmCLbl lbl
265 ASCII True (_UNPK_ s),
267 #if alpha_TARGET_ARCH
268 LDA dst (AddrImm imm_lbl)
271 MOV L (OpImm imm_lbl) (OpReg dst)
273 #if sparc_TARGET_ARCH
274 SETHI (HI imm_lbl) dst,
275 OR False dst (RIImm (LO imm_lbl)) dst
279 returnNat (Any PtrRep code)
283 -- end of machine-"independent" bit; here we go on the rest...
285 #if alpha_TARGET_ARCH
287 getRegister (StDouble d)
288 = getNatLabelNCG `thenNat` \ lbl ->
289 getNewRegNCG PtrRep `thenNat` \ tmp ->
290 let code dst = mkSeqInstrs [
293 DATA TF [ImmLab (rational d)],
295 LDA tmp (AddrImm (ImmCLbl lbl)),
296 LD TF dst (AddrReg tmp)]
298 returnNat (Any DoubleRep code)
300 getRegister (StPrim primop [x]) -- unary PrimOps
302 IntNegOp -> trivialUCode (NEG Q False) x
304 NotOp -> trivialUCode NOT x
306 FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
307 DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
309 OrdOp -> coerceIntCode IntRep x
312 Float2IntOp -> coerceFP2Int x
313 Int2FloatOp -> coerceInt2FP pr x
314 Double2IntOp -> coerceFP2Int x
315 Int2DoubleOp -> coerceInt2FP pr x
317 Double2FloatOp -> coerceFltCode x
318 Float2DoubleOp -> coerceFltCode x
320 other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
322 fn = case other_op of
323 FloatExpOp -> SLIT("exp")
324 FloatLogOp -> SLIT("log")
325 FloatSqrtOp -> SLIT("sqrt")
326 FloatSinOp -> SLIT("sin")
327 FloatCosOp -> SLIT("cos")
328 FloatTanOp -> SLIT("tan")
329 FloatAsinOp -> SLIT("asin")
330 FloatAcosOp -> SLIT("acos")
331 FloatAtanOp -> SLIT("atan")
332 FloatSinhOp -> SLIT("sinh")
333 FloatCoshOp -> SLIT("cosh")
334 FloatTanhOp -> SLIT("tanh")
335 DoubleExpOp -> SLIT("exp")
336 DoubleLogOp -> SLIT("log")
337 DoubleSqrtOp -> SLIT("sqrt")
338 DoubleSinOp -> SLIT("sin")
339 DoubleCosOp -> SLIT("cos")
340 DoubleTanOp -> SLIT("tan")
341 DoubleAsinOp -> SLIT("asin")
342 DoubleAcosOp -> SLIT("acos")
343 DoubleAtanOp -> SLIT("atan")
344 DoubleSinhOp -> SLIT("sinh")
345 DoubleCoshOp -> SLIT("cosh")
346 DoubleTanhOp -> SLIT("tanh")
348 pr = panic "MachCode.getRegister: no primrep needed for Alpha"
350 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
352 CharGtOp -> trivialCode (CMP LTT) y x
353 CharGeOp -> trivialCode (CMP LE) y x
354 CharEqOp -> trivialCode (CMP EQQ) x y
355 CharNeOp -> int_NE_code x y
356 CharLtOp -> trivialCode (CMP LTT) x y
357 CharLeOp -> trivialCode (CMP LE) x y
359 IntGtOp -> trivialCode (CMP LTT) y x
360 IntGeOp -> trivialCode (CMP LE) y x
361 IntEqOp -> trivialCode (CMP EQQ) x y
362 IntNeOp -> int_NE_code x y
363 IntLtOp -> trivialCode (CMP LTT) x y
364 IntLeOp -> trivialCode (CMP LE) x y
366 WordGtOp -> trivialCode (CMP ULT) y x
367 WordGeOp -> trivialCode (CMP ULE) x y
368 WordEqOp -> trivialCode (CMP EQQ) x y
369 WordNeOp -> int_NE_code x y
370 WordLtOp -> trivialCode (CMP ULT) x y
371 WordLeOp -> trivialCode (CMP ULE) x y
373 AddrGtOp -> trivialCode (CMP ULT) y x
374 AddrGeOp -> trivialCode (CMP ULE) y x
375 AddrEqOp -> trivialCode (CMP EQQ) x y
376 AddrNeOp -> int_NE_code x y
377 AddrLtOp -> trivialCode (CMP ULT) x y
378 AddrLeOp -> trivialCode (CMP ULE) x y
380 FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
381 FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
382 FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
383 FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
384 FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
385 FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
387 DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
388 DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
389 DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
390 DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
391 DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
392 DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
394 IntAddOp -> trivialCode (ADD Q False) x y
395 IntSubOp -> trivialCode (SUB Q False) x y
396 IntMulOp -> trivialCode (MUL Q False) x y
397 IntQuotOp -> trivialCode (DIV Q False) x y
398 IntRemOp -> trivialCode (REM Q False) x y
400 WordQuotOp -> trivialCode (DIV Q True) x y
401 WordRemOp -> trivialCode (REM Q True) x y
403 FloatAddOp -> trivialFCode FloatRep (FADD TF) x y
404 FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y
405 FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y
406 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y
408 DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y
409 DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y
410 DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y
411 DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y
413 AndOp -> trivialCode AND x y
414 OrOp -> trivialCode OR x y
415 XorOp -> trivialCode XOR x y
416 SllOp -> trivialCode SLL x y
417 SrlOp -> trivialCode SRL x y
419 ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
420 ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
421 ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
423 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
424 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
426 {- ------------------------------------------------------------
427 Some bizarre special code for getting condition codes into
428 registers. Integer non-equality is a test for equality
429 followed by an XOR with 1. (Integer comparisons always set
430 the result register to 0 or 1.) Floating point comparisons of
431 any kind leave the result in a floating point register, so we
432 need to wrangle an integer register out of things.
434 int_NE_code :: StixTree -> StixTree -> NatM Register
437 = trivialCode (CMP EQQ) x y `thenNat` \ register ->
438 getNewRegNCG IntRep `thenNat` \ tmp ->
440 code = registerCode register tmp
441 src = registerName register tmp
442 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
444 returnNat (Any IntRep code__2)
446 {- ------------------------------------------------------------
447 Comments for int_NE_code also apply to cmpF_code
450 :: (Reg -> Reg -> Reg -> Instr)
452 -> StixTree -> StixTree
455 cmpF_code instr cond x y
456 = trivialFCode pr instr x y `thenNat` \ register ->
457 getNewRegNCG DoubleRep `thenNat` \ tmp ->
458 getNatLabelNCG `thenNat` \ lbl ->
460 code = registerCode register tmp
461 result = registerName register tmp
463 code__2 dst = code . mkSeqInstrs [
464 OR zeroh (RIImm (ImmInt 1)) dst,
465 BF cond result (ImmCLbl lbl),
466 OR zeroh (RIReg zeroh) dst,
469 returnNat (Any IntRep code__2)
471 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
472 ------------------------------------------------------------
474 getRegister (StInd pk mem)
475 = getAmode mem `thenNat` \ amode ->
477 code = amodeCode amode
478 src = amodeAddr amode
479 size = primRepToSize pk
480 code__2 dst = code . mkSeqInstr (LD size dst src)
482 returnNat (Any pk code__2)
484 getRegister (StInt i)
487 code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
489 returnNat (Any IntRep code)
492 code dst = mkSeqInstr (LDI Q dst src)
494 returnNat (Any IntRep code)
496 src = ImmInt (fromInteger i)
501 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
503 returnNat (Any PtrRep code)
506 imm__2 = case imm of Just x -> x
508 #endif {- alpha_TARGET_ARCH -}
509 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
512 getRegister (StDouble d)
515 = let code dst = unitOL (GLDZ dst)
516 in returnNat (Any DoubleRep code)
519 = let code dst = unitOL (GLD1 dst)
520 in returnNat (Any DoubleRep code)
523 = getNatLabelNCG `thenNat` \ lbl ->
524 let code dst = toOL [
527 DATA DF [ImmDouble d],
529 GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
532 returnNat (Any DoubleRep code)
534 -- Calculate the offset for (i+1) words above the _initial_
535 -- %esp value by first determining the current offset of it.
536 getRegister (StScratchWord i)
538 = getDeltaNat `thenNat` \ current_stack_offset ->
539 let j = i+1 - (current_stack_offset `div` 4)
541 = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst))
543 returnNat (Any PtrRep code)
545 getRegister (StPrim primop [x]) -- unary PrimOps
547 IntNegOp -> trivialUCode (NEGI L) x
548 NotOp -> trivialUCode (NOT L) x
550 FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
551 DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
553 FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
554 DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
556 FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
557 DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
559 FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
560 DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
562 FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
563 DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x
565 Double2FloatOp -> trivialUFCode FloatRep GDTOF x
566 Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
568 OrdOp -> coerceIntCode IntRep x
571 Float2IntOp -> coerceFP2Int x
572 Int2FloatOp -> coerceInt2FP FloatRep x
573 Double2IntOp -> coerceFP2Int x
574 Int2DoubleOp -> coerceInt2FP DoubleRep x
578 fixed_x = if is_float_op -- promote to double
579 then StPrim Float2DoubleOp [x]
582 getRegister (StCall fn cCallConv DoubleRep [x])
586 FloatExpOp -> (True, SLIT("exp"))
587 FloatLogOp -> (True, SLIT("log"))
589 FloatAsinOp -> (True, SLIT("asin"))
590 FloatAcosOp -> (True, SLIT("acos"))
591 FloatAtanOp -> (True, SLIT("atan"))
593 FloatSinhOp -> (True, SLIT("sinh"))
594 FloatCoshOp -> (True, SLIT("cosh"))
595 FloatTanhOp -> (True, SLIT("tanh"))
597 DoubleExpOp -> (False, SLIT("exp"))
598 DoubleLogOp -> (False, SLIT("log"))
600 DoubleAsinOp -> (False, SLIT("asin"))
601 DoubleAcosOp -> (False, SLIT("acos"))
602 DoubleAtanOp -> (False, SLIT("atan"))
604 DoubleSinhOp -> (False, SLIT("sinh"))
605 DoubleCoshOp -> (False, SLIT("cosh"))
606 DoubleTanhOp -> (False, SLIT("tanh"))
609 -> pprPanic "getRegister(x86,unary primop)"
610 (pprStixTree (StPrim primop [x]))
612 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
614 CharGtOp -> condIntReg GTT x y
615 CharGeOp -> condIntReg GE x y
616 CharEqOp -> condIntReg EQQ x y
617 CharNeOp -> condIntReg NE x y
618 CharLtOp -> condIntReg LTT x y
619 CharLeOp -> condIntReg LE x y
621 IntGtOp -> condIntReg GTT x y
622 IntGeOp -> condIntReg GE x y
623 IntEqOp -> condIntReg EQQ x y
624 IntNeOp -> condIntReg NE x y
625 IntLtOp -> condIntReg LTT x y
626 IntLeOp -> condIntReg LE x y
628 WordGtOp -> condIntReg GU x y
629 WordGeOp -> condIntReg GEU x y
630 WordEqOp -> condIntReg EQQ x y
631 WordNeOp -> condIntReg NE x y
632 WordLtOp -> condIntReg LU x y
633 WordLeOp -> condIntReg LEU x y
635 AddrGtOp -> condIntReg GU x y
636 AddrGeOp -> condIntReg GEU x y
637 AddrEqOp -> condIntReg EQQ x y
638 AddrNeOp -> condIntReg NE x y
639 AddrLtOp -> condIntReg LU x y
640 AddrLeOp -> condIntReg LEU x y
642 FloatGtOp -> condFltReg GTT x y
643 FloatGeOp -> condFltReg GE x y
644 FloatEqOp -> condFltReg EQQ x y
645 FloatNeOp -> condFltReg NE x y
646 FloatLtOp -> condFltReg LTT x y
647 FloatLeOp -> condFltReg LE x y
649 DoubleGtOp -> condFltReg GTT x y
650 DoubleGeOp -> condFltReg GE x y
651 DoubleEqOp -> condFltReg EQQ x y
652 DoubleNeOp -> condFltReg NE x y
653 DoubleLtOp -> condFltReg LTT x y
654 DoubleLeOp -> condFltReg LE x y
656 IntAddOp -> add_code L x y
657 IntSubOp -> sub_code L x y
658 IntQuotOp -> quot_code L x y True{-division-}
659 IntRemOp -> quot_code L x y False{-remainder-}
660 IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y
662 FloatAddOp -> trivialFCode FloatRep GADD x y
663 FloatSubOp -> trivialFCode FloatRep GSUB x y
664 FloatMulOp -> trivialFCode FloatRep GMUL x y
665 FloatDivOp -> trivialFCode FloatRep GDIV x y
667 DoubleAddOp -> trivialFCode DoubleRep GADD x y
668 DoubleSubOp -> trivialFCode DoubleRep GSUB x y
669 DoubleMulOp -> trivialFCode DoubleRep GMUL x y
670 DoubleDivOp -> trivialFCode DoubleRep GDIV x y
672 AndOp -> let op = AND L in trivialCode op (Just op) x y
673 OrOp -> let op = OR L in trivialCode op (Just op) x y
674 XorOp -> let op = XOR L in trivialCode op (Just op) x y
676 {- Shift ops on x86s have constraints on their source, it
677 either has to be Imm, CL or 1
678 => trivialCode's is not restrictive enough (sigh.)
681 SllOp -> shift_code (SHL L) x y {-False-}
682 SrlOp -> shift_code (SHR L) x y {-False-}
683 ISllOp -> shift_code (SHL L) x y {-False-}
684 ISraOp -> shift_code (SAR L) x y {-False-}
685 ISrlOp -> shift_code (SHR L) x y {-False-}
687 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
688 [promote x, promote y])
689 where promote x = StPrim Float2DoubleOp [x]
690 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
693 -> pprPanic "getRegister(x86,dyadic primop)"
694 (pprStixTree (StPrim primop [x, y]))
698 shift_code :: (Imm -> Operand -> Instr)
703 {- Case1: shift length as immediate -}
704 -- Code is the same as the first eq. for trivialCode -- sigh.
705 shift_code instr x y{-amount-}
707 = getRegister x `thenNat` \ regx ->
710 then registerCodeA regx dst `bind` \ code_x ->
712 instr imm__2 (OpReg dst)
713 else registerCodeF regx `bind` \ code_x ->
714 registerNameF regx `bind` \ r_x ->
716 MOV L (OpReg r_x) (OpReg dst) `snocOL`
717 instr imm__2 (OpReg dst)
719 returnNat (Any IntRep mkcode)
722 imm__2 = case imm of Just x -> x
724 {- Case2: shift length is complex (non-immediate) -}
725 -- Since ECX is always used as a spill temporary, we can't
726 -- use it here to do non-immediate shifts. No big deal --
727 -- they are only very rare, and we can use an equivalent
728 -- test-and-jump sequence which doesn't use ECX.
729 -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
730 -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
731 shift_code instr x y{-amount-}
732 = getRegister x `thenNat` \ register1 ->
733 getRegister y `thenNat` \ register2 ->
734 getNatLabelNCG `thenNat` \ lbl_test3 ->
735 getNatLabelNCG `thenNat` \ lbl_test2 ->
736 getNatLabelNCG `thenNat` \ lbl_test1 ->
737 getNatLabelNCG `thenNat` \ lbl_test0 ->
738 getNatLabelNCG `thenNat` \ lbl_after ->
739 getNewRegNCG IntRep `thenNat` \ tmp ->
741 = let src_val = registerName register1 dst
742 code_val = registerCode register1 dst
743 src_amt = registerName register2 tmp
744 code_amt = registerCode register2 tmp
749 MOV L (OpReg src_amt) r_tmp `appOL`
751 MOV L (OpReg src_val) r_dst `appOL`
753 COMMENT (_PK_ "begin shift sequence"),
754 MOV L (OpReg src_val) r_dst,
755 MOV L (OpReg src_amt) r_tmp,
757 BT L (ImmInt 4) r_tmp,
759 instr (ImmInt 16) r_dst,
762 BT L (ImmInt 3) r_tmp,
764 instr (ImmInt 8) r_dst,
767 BT L (ImmInt 2) r_tmp,
769 instr (ImmInt 4) r_dst,
772 BT L (ImmInt 1) r_tmp,
774 instr (ImmInt 2) r_dst,
777 BT L (ImmInt 0) r_tmp,
779 instr (ImmInt 1) r_dst,
782 COMMENT (_PK_ "end shift sequence")
785 returnNat (Any IntRep code__2)
788 add_code :: Size -> StixTree -> StixTree -> NatM Register
790 add_code sz x (StInt y)
791 = getRegister x `thenNat` \ register ->
792 getNewRegNCG IntRep `thenNat` \ tmp ->
794 code = registerCode register tmp
795 src1 = registerName register tmp
796 src2 = ImmInt (fromInteger y)
799 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
802 returnNat (Any IntRep code__2)
804 add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
807 sub_code :: Size -> StixTree -> StixTree -> NatM Register
809 sub_code sz x (StInt y)
810 = getRegister x `thenNat` \ register ->
811 getNewRegNCG IntRep `thenNat` \ tmp ->
813 code = registerCode register tmp
814 src1 = registerName register tmp
815 src2 = ImmInt (-(fromInteger y))
818 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
821 returnNat (Any IntRep code__2)
823 sub_code sz x y = trivialCode (SUB sz) Nothing x y
828 -> StixTree -> StixTree
829 -> Bool -- True => division, False => remainder operation
832 -- x must go into eax, edx must be a sign-extension of eax, and y
833 -- should go in some other register (or memory), so that we get
834 -- edx:eax / reg -> eax (remainder in edx). Currently we choose
835 -- to put y on the C stack, since that avoids tying up yet another
836 -- precious register.
838 quot_code sz x y is_division
839 = getRegister x `thenNat` \ register1 ->
840 getRegister y `thenNat` \ register2 ->
841 getNewRegNCG IntRep `thenNat` \ tmp ->
842 getDeltaNat `thenNat` \ delta ->
844 code1 = registerCode register1 tmp
845 src1 = registerName register1 tmp
846 code2 = registerCode register2 tmp
847 src2 = registerName register2 tmp
848 code__2 = code2 `snocOL` -- src2 := y
849 PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y
850 DELTA (delta-4) `appOL`
851 code1 `snocOL` -- src1 := x
852 MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x
854 IDIV sz (OpAddr (spRel 0)) `snocOL`
855 ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
858 returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
859 -----------------------
861 getRegister (StInd pk mem)
862 = getAmode mem `thenNat` \ amode ->
864 code = amodeCode amode
865 src = amodeAddr amode
866 size = primRepToSize pk
867 code__2 dst = code `snocOL`
868 if pk == DoubleRep || pk == FloatRep
869 then GLD size src dst
871 L -> MOV L (OpAddr src) (OpReg dst)
872 B -> MOVZxL B (OpAddr src) (OpReg dst)
874 returnNat (Any pk code__2)
876 getRegister (StInt i)
878 src = ImmInt (fromInteger i)
881 = unitOL (XOR L (OpReg dst) (OpReg dst))
883 = unitOL (MOV L (OpImm src) (OpReg dst))
885 returnNat (Any IntRep code)
889 = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
891 returnNat (Any PtrRep code)
893 = pprPanic "getRegister(x86)" (pprStixTree leaf)
896 imm__2 = case imm of Just x -> x
898 #endif {- i386_TARGET_ARCH -}
899 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
900 #if sparc_TARGET_ARCH
902 getRegister (StFloat d)
903 = getNatLabelNCG `thenNat` \ lbl ->
904 getNewRegNCG PtrRep `thenNat` \ tmp ->
905 let code dst = toOL [
910 SETHI (HI (ImmCLbl lbl)) tmp,
911 LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
913 returnNat (Any FloatRep code)
915 getRegister (StDouble d)
916 = getNatLabelNCG `thenNat` \ lbl ->
917 getNewRegNCG PtrRep `thenNat` \ tmp ->
918 let code dst = toOL [
921 DATA DF [ImmDouble d],
923 SETHI (HI (ImmCLbl lbl)) tmp,
924 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
926 returnNat (Any DoubleRep code)
928 -- The 6-word scratch area is immediately below the frame pointer.
929 -- Below that is the spill area.
930 getRegister (StScratchWord i)
933 code dst = unitOL (fpRelEA j dst)
935 returnNat (Any PtrRep code)
938 getRegister (StPrim primop [x]) -- unary PrimOps
940 IntNegOp -> trivialUCode (SUB False False g0) x
941 NotOp -> trivialUCode (XNOR False g0) x
943 FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
944 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
946 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
947 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
949 OrdOp -> coerceIntCode IntRep x
952 Float2IntOp -> coerceFP2Int x
953 Int2FloatOp -> coerceInt2FP FloatRep x
954 Double2IntOp -> coerceFP2Int x
955 Int2DoubleOp -> coerceInt2FP DoubleRep x
959 fixed_x = if is_float_op -- promote to double
960 then StPrim Float2DoubleOp [x]
963 getRegister (StCall fn cCallConv DoubleRep [fixed_x])
967 FloatExpOp -> (True, SLIT("exp"))
968 FloatLogOp -> (True, SLIT("log"))
969 FloatSqrtOp -> (True, SLIT("sqrt"))
971 FloatSinOp -> (True, SLIT("sin"))
972 FloatCosOp -> (True, SLIT("cos"))
973 FloatTanOp -> (True, SLIT("tan"))
975 FloatAsinOp -> (True, SLIT("asin"))
976 FloatAcosOp -> (True, SLIT("acos"))
977 FloatAtanOp -> (True, SLIT("atan"))
979 FloatSinhOp -> (True, SLIT("sinh"))
980 FloatCoshOp -> (True, SLIT("cosh"))
981 FloatTanhOp -> (True, SLIT("tanh"))
983 DoubleExpOp -> (False, SLIT("exp"))
984 DoubleLogOp -> (False, SLIT("log"))
985 DoubleSqrtOp -> (False, SLIT("sqrt"))
987 DoubleSinOp -> (False, SLIT("sin"))
988 DoubleCosOp -> (False, SLIT("cos"))
989 DoubleTanOp -> (False, SLIT("tan"))
991 DoubleAsinOp -> (False, SLIT("asin"))
992 DoubleAcosOp -> (False, SLIT("acos"))
993 DoubleAtanOp -> (False, SLIT("atan"))
995 DoubleSinhOp -> (False, SLIT("sinh"))
996 DoubleCoshOp -> (False, SLIT("cosh"))
997 DoubleTanhOp -> (False, SLIT("tanh"))
1000 -> pprPanic "getRegister(sparc,monadicprimop)"
1001 (pprStixTree (StPrim primop [x]))
1003 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1005 CharGtOp -> condIntReg GTT x y
1006 CharGeOp -> condIntReg GE x y
1007 CharEqOp -> condIntReg EQQ x y
1008 CharNeOp -> condIntReg NE x y
1009 CharLtOp -> condIntReg LTT x y
1010 CharLeOp -> condIntReg LE x y
1012 IntGtOp -> condIntReg GTT x y
1013 IntGeOp -> condIntReg GE x y
1014 IntEqOp -> condIntReg EQQ x y
1015 IntNeOp -> condIntReg NE x y
1016 IntLtOp -> condIntReg LTT x y
1017 IntLeOp -> condIntReg LE x y
1019 WordGtOp -> condIntReg GU x y
1020 WordGeOp -> condIntReg GEU x y
1021 WordEqOp -> condIntReg EQQ x y
1022 WordNeOp -> condIntReg NE x y
1023 WordLtOp -> condIntReg LU x y
1024 WordLeOp -> condIntReg LEU x y
1026 AddrGtOp -> condIntReg GU x y
1027 AddrGeOp -> condIntReg GEU x y
1028 AddrEqOp -> condIntReg EQQ x y
1029 AddrNeOp -> condIntReg NE x y
1030 AddrLtOp -> condIntReg LU x y
1031 AddrLeOp -> condIntReg LEU x y
1033 FloatGtOp -> condFltReg GTT x y
1034 FloatGeOp -> condFltReg GE x y
1035 FloatEqOp -> condFltReg EQQ x y
1036 FloatNeOp -> condFltReg NE x y
1037 FloatLtOp -> condFltReg LTT x y
1038 FloatLeOp -> condFltReg LE x y
1040 DoubleGtOp -> condFltReg GTT x y
1041 DoubleGeOp -> condFltReg GE x y
1042 DoubleEqOp -> condFltReg EQQ x y
1043 DoubleNeOp -> condFltReg NE x y
1044 DoubleLtOp -> condFltReg LTT x y
1045 DoubleLeOp -> condFltReg LE x y
1047 IntAddOp -> trivialCode (ADD False False) x y
1048 IntSubOp -> trivialCode (SUB False False) x y
1050 -- ToDo: teach about V8+ SPARC mul/div instructions
1051 IntMulOp -> imul_div SLIT(".umul") x y
1052 IntQuotOp -> imul_div SLIT(".div") x y
1053 IntRemOp -> imul_div SLIT(".rem") x y
1055 FloatAddOp -> trivialFCode FloatRep FADD x y
1056 FloatSubOp -> trivialFCode FloatRep FSUB x y
1057 FloatMulOp -> trivialFCode FloatRep FMUL x y
1058 FloatDivOp -> trivialFCode FloatRep FDIV x y
1060 DoubleAddOp -> trivialFCode DoubleRep FADD x y
1061 DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1062 DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1063 DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1065 AndOp -> trivialCode (AND False) x y
1066 OrOp -> trivialCode (OR False) x y
1067 XorOp -> trivialCode (XOR False) x y
1068 SllOp -> trivialCode SLL x y
1069 SrlOp -> trivialCode SRL x y
1071 ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
1072 ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
1073 ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
1075 FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1076 [promote x, promote y])
1077 where promote x = StPrim Float2DoubleOp [x]
1078 DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1082 -> pprPanic "getRegister(sparc,dyadic primop)"
1083 (pprStixTree (StPrim primop [x, y]))
1086 imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1088 getRegister (StInd pk mem)
1089 = getAmode mem `thenNat` \ amode ->
1091 code = amodeCode amode
1092 src = amodeAddr amode
1093 size = primRepToSize pk
1094 code__2 dst = code `snocOL` LD size src dst
1096 returnNat (Any pk code__2)
1098 getRegister (StInt i)
1101 src = ImmInt (fromInteger i)
1102 code dst = unitOL (OR False g0 (RIImm src) dst)
1104 returnNat (Any IntRep code)
1110 SETHI (HI imm__2) dst,
1111 OR False dst (RIImm (LO imm__2)) dst]
1113 returnNat (Any PtrRep code)
1115 = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1118 imm__2 = case imm of Just x -> x
1120 #endif {- sparc_TARGET_ARCH -}
1123 %************************************************************************
1125 \subsection{The @Amode@ type}
1127 %************************************************************************
1129 @Amode@s: Memory addressing modes passed up the tree.
1131 data Amode = Amode MachRegsAddr InstrBlock
1133 amodeAddr (Amode addr _) = addr
1134 amodeCode (Amode _ code) = code
1137 Now, given a tree (the argument to an StInd) that references memory,
1138 produce a suitable addressing mode.
1140 A Rule of the Game (tm) for Amodes: use of the addr bit must
1141 immediately follow use of the code part, since the code part puts
1142 values in registers which the addr then refers to. So you can't put
1143 anything in between, lest it overwrite some of those registers. If
1144 you need to do some other computation between the code part and use of
1145 the addr bit, first store the effective address from the amode in a
1146 temporary, then do the other computation, and then use the temporary:
1150 ... other computation ...
1154 getAmode :: StixTree -> NatM Amode
1156 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1158 #if alpha_TARGET_ARCH
1160 getAmode (StPrim IntSubOp [x, StInt i])
1161 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1162 getRegister x `thenNat` \ register ->
1164 code = registerCode register tmp
1165 reg = registerName register tmp
1166 off = ImmInt (-(fromInteger i))
1168 returnNat (Amode (AddrRegImm reg off) code)
1170 getAmode (StPrim IntAddOp [x, StInt i])
1171 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1172 getRegister x `thenNat` \ register ->
1174 code = registerCode register tmp
1175 reg = registerName register tmp
1176 off = ImmInt (fromInteger i)
1178 returnNat (Amode (AddrRegImm reg off) code)
1182 = returnNat (Amode (AddrImm imm__2) id)
1185 imm__2 = case imm of Just x -> x
1188 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1189 getRegister other `thenNat` \ register ->
1191 code = registerCode register tmp
1192 reg = registerName register tmp
1194 returnNat (Amode (AddrReg reg) code)
1196 #endif {- alpha_TARGET_ARCH -}
1197 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1198 #if i386_TARGET_ARCH
1200 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 (AddrBaseIndex (Just reg) Nothing off) code)
1210 getAmode (StPrim IntAddOp [x, StInt i])
1212 = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1215 imm__2 = case imm of Just x -> x
1217 getAmode (StPrim IntAddOp [x, StInt i])
1218 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1219 getRegister x `thenNat` \ register ->
1221 code = registerCode register tmp
1222 reg = registerName register tmp
1223 off = ImmInt (fromInteger i)
1225 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1227 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1228 | shift == 0 || shift == 1 || shift == 2 || shift == 3
1229 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1230 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1231 getRegister x `thenNat` \ register1 ->
1232 getRegister y `thenNat` \ register2 ->
1234 code1 = registerCode register1 tmp1
1235 reg1 = registerName register1 tmp1
1236 code2 = registerCode register2 tmp2
1237 reg2 = registerName register2 tmp2
1238 code__2 = code1 `appOL` code2
1239 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1241 returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1246 = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1249 imm__2 = case imm of Just x -> x
1252 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1253 getRegister other `thenNat` \ register ->
1255 code = registerCode register tmp
1256 reg = registerName register tmp
1258 returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1260 #endif {- i386_TARGET_ARCH -}
1261 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1262 #if sparc_TARGET_ARCH
1264 getAmode (StPrim IntSubOp [x, StInt i])
1266 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1267 getRegister x `thenNat` \ register ->
1269 code = registerCode register tmp
1270 reg = registerName register tmp
1271 off = ImmInt (-(fromInteger i))
1273 returnNat (Amode (AddrRegImm reg off) code)
1276 getAmode (StPrim IntAddOp [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)
1287 getAmode (StPrim IntAddOp [x, y])
1288 = getNewRegNCG PtrRep `thenNat` \ tmp1 ->
1289 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1290 getRegister x `thenNat` \ register1 ->
1291 getRegister y `thenNat` \ register2 ->
1293 code1 = registerCode register1 tmp1
1294 reg1 = registerName register1 tmp1
1295 code2 = registerCode register2 tmp2
1296 reg2 = registerName register2 tmp2
1297 code__2 = code1 `appOL` code2
1299 returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1303 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1305 code = unitOL (SETHI (HI imm__2) tmp)
1307 returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1310 imm__2 = case imm of Just x -> x
1313 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1314 getRegister other `thenNat` \ register ->
1316 code = registerCode register tmp
1317 reg = registerName register tmp
1320 returnNat (Amode (AddrRegImm reg off) code)
1322 #endif {- sparc_TARGET_ARCH -}
1325 %************************************************************************
1327 \subsection{The @CondCode@ type}
1329 %************************************************************************
1331 Condition codes passed up the tree.
1333 data CondCode = CondCode Bool Cond InstrBlock
1335 condName (CondCode _ cond _) = cond
1336 condFloat (CondCode is_float _ _) = is_float
1337 condCode (CondCode _ _ code) = code
1340 Set up a condition code for a conditional branch.
1343 getCondCode :: StixTree -> NatM CondCode
1345 #if alpha_TARGET_ARCH
1346 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1347 #endif {- alpha_TARGET_ARCH -}
1348 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1350 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1351 -- yes, they really do seem to want exactly the same!
1353 getCondCode (StPrim primop [x, y])
1355 CharGtOp -> condIntCode GTT x y
1356 CharGeOp -> condIntCode GE x y
1357 CharEqOp -> condIntCode EQQ x y
1358 CharNeOp -> condIntCode NE x y
1359 CharLtOp -> condIntCode LTT x y
1360 CharLeOp -> condIntCode LE x y
1362 IntGtOp -> condIntCode GTT x y
1363 IntGeOp -> condIntCode GE x y
1364 IntEqOp -> condIntCode EQQ x y
1365 IntNeOp -> condIntCode NE x y
1366 IntLtOp -> condIntCode LTT x y
1367 IntLeOp -> condIntCode LE x y
1369 WordGtOp -> condIntCode GU x y
1370 WordGeOp -> condIntCode GEU x y
1371 WordEqOp -> condIntCode EQQ x y
1372 WordNeOp -> condIntCode NE x y
1373 WordLtOp -> condIntCode LU x y
1374 WordLeOp -> condIntCode LEU x y
1376 AddrGtOp -> condIntCode GU x y
1377 AddrGeOp -> condIntCode GEU x y
1378 AddrEqOp -> condIntCode EQQ x y
1379 AddrNeOp -> condIntCode NE x y
1380 AddrLtOp -> condIntCode LU x y
1381 AddrLeOp -> condIntCode LEU x y
1383 FloatGtOp -> condFltCode GTT x y
1384 FloatGeOp -> condFltCode GE x y
1385 FloatEqOp -> condFltCode EQQ x y
1386 FloatNeOp -> condFltCode NE x y
1387 FloatLtOp -> condFltCode LTT x y
1388 FloatLeOp -> condFltCode LE x y
1390 DoubleGtOp -> condFltCode GTT x y
1391 DoubleGeOp -> condFltCode GE x y
1392 DoubleEqOp -> condFltCode EQQ x y
1393 DoubleNeOp -> condFltCode NE x y
1394 DoubleLtOp -> condFltCode LTT x y
1395 DoubleLeOp -> condFltCode LE x y
1397 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1402 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1403 passed back up the tree.
1406 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1408 #if alpha_TARGET_ARCH
1409 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1410 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1411 #endif {- alpha_TARGET_ARCH -}
1413 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1414 #if i386_TARGET_ARCH
1416 -- memory vs immediate
1417 condIntCode cond (StInd pk x) y
1419 = getAmode x `thenNat` \ amode ->
1421 code1 = amodeCode amode
1422 x__2 = amodeAddr amode
1423 sz = primRepToSize pk
1424 code__2 = code1 `snocOL`
1425 CMP sz (OpImm imm__2) (OpAddr x__2)
1427 returnNat (CondCode False cond code__2)
1430 imm__2 = case imm of Just x -> x
1433 condIntCode cond x (StInt 0)
1434 = getRegister x `thenNat` \ register1 ->
1435 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1437 code1 = registerCode register1 tmp1
1438 src1 = registerName register1 tmp1
1439 code__2 = code1 `snocOL`
1440 TEST L (OpReg src1) (OpReg src1)
1442 returnNat (CondCode False cond code__2)
1444 -- anything vs immediate
1445 condIntCode cond x y
1447 = getRegister x `thenNat` \ register1 ->
1448 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1450 code1 = registerCode register1 tmp1
1451 src1 = registerName register1 tmp1
1452 code__2 = code1 `snocOL`
1453 CMP L (OpImm imm__2) (OpReg src1)
1455 returnNat (CondCode False cond code__2)
1458 imm__2 = case imm of Just x -> x
1460 -- memory vs anything
1461 condIntCode cond (StInd pk x) y
1462 = getAmode x `thenNat` \ amode_x ->
1463 getRegister y `thenNat` \ reg_y ->
1464 getNewRegNCG IntRep `thenNat` \ tmp ->
1466 c_x = amodeCode amode_x
1467 am_x = amodeAddr amode_x
1468 c_y = registerCode reg_y tmp
1469 r_y = registerName reg_y tmp
1470 sz = primRepToSize pk
1472 -- optimisation: if there's no code for x, just an amode,
1473 -- use whatever reg y winds up in. Assumes that c_y doesn't
1474 -- clobber any regs in the amode am_x, which I'm not sure is
1475 -- justified. The otherwise clause makes the same assumption.
1476 code__2 | isNilOL c_x
1478 CMP sz (OpReg r_y) (OpAddr am_x)
1482 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1484 CMP sz (OpReg tmp) (OpAddr am_x)
1486 returnNat (CondCode False cond code__2)
1488 -- anything vs memory
1490 condIntCode cond y (StInd pk x)
1491 = getAmode x `thenNat` \ amode_x ->
1492 getRegister y `thenNat` \ reg_y ->
1493 getNewRegNCG IntRep `thenNat` \ tmp ->
1495 c_x = amodeCode amode_x
1496 am_x = amodeAddr amode_x
1497 c_y = registerCode reg_y tmp
1498 r_y = registerName reg_y tmp
1499 sz = primRepToSize pk
1500 -- same optimisation and nagging doubts as previous clause
1501 code__2 | isNilOL c_x
1503 CMP sz (OpAddr am_x) (OpReg r_y)
1507 MOV L (OpReg r_y) (OpReg tmp) `appOL`
1509 CMP sz (OpAddr am_x) (OpReg tmp)
1511 returnNat (CondCode False cond code__2)
1513 -- anything vs anything
1514 condIntCode cond x y
1515 = getRegister x `thenNat` \ register1 ->
1516 getRegister y `thenNat` \ register2 ->
1517 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1518 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1520 code1 = registerCode register1 tmp1
1521 src1 = registerName register1 tmp1
1522 code2 = registerCode register2 tmp2
1523 src2 = registerName register2 tmp2
1524 code__2 = code1 `snocOL`
1525 MOV L (OpReg src1) (OpReg tmp1) `appOL`
1527 CMP L (OpReg src2) (OpReg tmp1)
1529 returnNat (CondCode False cond code__2)
1532 condFltCode cond x y
1533 = getRegister x `thenNat` \ register1 ->
1534 getRegister y `thenNat` \ register2 ->
1535 getNewRegNCG (registerRep register1)
1537 getNewRegNCG (registerRep register2)
1539 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1541 pk1 = registerRep register1
1542 code1 = registerCode register1 tmp1
1543 src1 = registerName register1 tmp1
1545 pk2 = registerRep register2
1546 code2 = registerCode register2 tmp2
1547 src2 = registerName register2 tmp2
1549 code__2 | isAny register1
1550 = code1 `appOL` -- result in tmp1
1552 GCMP (primRepToSize pk1) tmp1 src2
1556 GMOV src1 tmp1 `appOL`
1558 GCMP (primRepToSize pk1) tmp1 src2
1560 {- On the 486, the flags set by FP compare are the unsigned ones!
1561 (This looks like a HACK to me. WDP 96/03)
1563 fix_FP_cond :: Cond -> Cond
1565 fix_FP_cond GE = GEU
1566 fix_FP_cond GTT = GU
1567 fix_FP_cond LTT = LU
1568 fix_FP_cond LE = LEU
1569 fix_FP_cond any = any
1571 returnNat (CondCode True (fix_FP_cond cond) code__2)
1575 #endif {- i386_TARGET_ARCH -}
1576 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1577 #if sparc_TARGET_ARCH
1579 condIntCode cond x (StInt y)
1581 = getRegister x `thenNat` \ register ->
1582 getNewRegNCG IntRep `thenNat` \ tmp ->
1584 code = registerCode register tmp
1585 src1 = registerName register tmp
1586 src2 = ImmInt (fromInteger y)
1587 code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1589 returnNat (CondCode False cond code__2)
1591 condIntCode cond x y
1592 = getRegister x `thenNat` \ register1 ->
1593 getRegister y `thenNat` \ register2 ->
1594 getNewRegNCG IntRep `thenNat` \ tmp1 ->
1595 getNewRegNCG IntRep `thenNat` \ tmp2 ->
1597 code1 = registerCode register1 tmp1
1598 src1 = registerName register1 tmp1
1599 code2 = registerCode register2 tmp2
1600 src2 = registerName register2 tmp2
1601 code__2 = code1 `appOL` code2 `snocOL`
1602 SUB False True src1 (RIReg src2) g0
1604 returnNat (CondCode False cond code__2)
1607 condFltCode cond x y
1608 = getRegister x `thenNat` \ register1 ->
1609 getRegister y `thenNat` \ register2 ->
1610 getNewRegNCG (registerRep register1)
1612 getNewRegNCG (registerRep register2)
1614 getNewRegNCG DoubleRep `thenNat` \ tmp ->
1616 promote x = FxTOy F DF x tmp
1618 pk1 = registerRep register1
1619 code1 = registerCode register1 tmp1
1620 src1 = registerName register1 tmp1
1622 pk2 = registerRep register2
1623 code2 = registerCode register2 tmp2
1624 src2 = registerName register2 tmp2
1628 code1 `appOL` code2 `snocOL`
1629 FCMP True (primRepToSize pk1) src1 src2
1630 else if pk1 == FloatRep then
1631 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1632 FCMP True DF tmp src2
1634 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1635 FCMP True DF src1 tmp
1637 returnNat (CondCode True cond code__2)
1639 #endif {- sparc_TARGET_ARCH -}
1642 %************************************************************************
1644 \subsection{Generating assignments}
1646 %************************************************************************
1648 Assignments are really at the heart of the whole code generation
1649 business. Almost all top-level nodes of any real importance are
1650 assignments, which correspond to loads, stores, or register transfers.
1651 If we're really lucky, some of the register transfers will go away,
1652 because we can use the destination register to complete the code
1653 generation for the right hand side. This only fails when the right
1654 hand side is forced into a fixed register (e.g. the result of a call).
1657 assignIntCode, assignFltCode
1658 :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1660 #if alpha_TARGET_ARCH
1662 assignIntCode pk (StInd _ dst) src
1663 = getNewRegNCG IntRep `thenNat` \ tmp ->
1664 getAmode dst `thenNat` \ amode ->
1665 getRegister src `thenNat` \ register ->
1667 code1 = amodeCode amode []
1668 dst__2 = amodeAddr amode
1669 code2 = registerCode register tmp []
1670 src__2 = registerName register tmp
1671 sz = primRepToSize pk
1672 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1676 assignIntCode pk dst src
1677 = getRegister dst `thenNat` \ register1 ->
1678 getRegister src `thenNat` \ register2 ->
1680 dst__2 = registerName register1 zeroh
1681 code = registerCode register2 dst__2
1682 src__2 = registerName register2 dst__2
1683 code__2 = if isFixed register2
1684 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1689 #endif {- alpha_TARGET_ARCH -}
1690 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1691 #if i386_TARGET_ARCH
1693 -- Destination of an assignment can only be reg or mem.
1694 -- This is the mem case.
1695 assignIntCode pk (StInd _ dst) src
1696 = getAmode dst `thenNat` \ amode ->
1697 get_op_RI src `thenNat` \ (codesrc, opsrc) ->
1698 getNewRegNCG PtrRep `thenNat` \ tmp ->
1700 -- In general, if the address computation for dst may require
1701 -- some insns preceding the addressing mode itself. So there's
1702 -- no guarantee that the code for dst and the code for src won't
1703 -- write the same register. This means either the address or
1704 -- the value needs to be copied into a temporary. We detect the
1705 -- common case where the amode has no code, and elide the copy.
1706 codea = amodeCode amode
1707 dst__a = amodeAddr amode
1709 code | isNilOL codea
1711 MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1715 LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1717 MOV (primRepToSize pk) opsrc
1718 (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1724 -> NatM (InstrBlock,Operand) -- code, operator
1728 = returnNat (nilOL, OpImm imm_op)
1731 imm_op = case imm of Just x -> x
1734 = getRegister op `thenNat` \ register ->
1735 getNewRegNCG (registerRep register)
1737 let code = registerCode register tmp
1738 reg = registerName register tmp
1740 returnNat (code, OpReg reg)
1742 -- Assign; dst is a reg, rhs is mem
1743 assignIntCode pk dst (StInd pks src)
1744 = getNewRegNCG PtrRep `thenNat` \ tmp ->
1745 getAmode src `thenNat` \ amode ->
1746 getRegister dst `thenNat` \ reg_dst ->
1748 c_addr = amodeCode amode
1749 am_addr = amodeAddr amode
1751 c_dst = registerCode reg_dst tmp -- should be empty
1752 r_dst = registerName reg_dst tmp
1753 szs = primRepToSize pks
1754 opc = case szs of L -> MOV L ; B -> MOVZxL B
1756 code | isNilOL c_dst
1758 opc (OpAddr am_addr) (OpReg r_dst)
1760 = pprPanic "assignIntCode(x86): bad dst(2)" empty
1764 -- dst is a reg, but src could be anything
1765 assignIntCode pk dst src
1766 = getRegister dst `thenNat` \ registerd ->
1767 getRegister src `thenNat` \ registers ->
1768 getNewRegNCG IntRep `thenNat` \ tmp ->
1770 r_dst = registerName registerd tmp
1771 c_dst = registerCode registerd tmp -- should be empty
1772 r_src = registerName registers r_dst
1773 c_src = registerCode registers r_dst
1775 code | isNilOL c_dst
1777 MOV L (OpReg r_src) (OpReg r_dst)
1779 = pprPanic "assignIntCode(x86): bad dst(3)" empty
1783 #endif {- i386_TARGET_ARCH -}
1784 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1785 #if sparc_TARGET_ARCH
1787 assignIntCode pk (StInd _ dst) src
1788 = getNewRegNCG IntRep `thenNat` \ tmp ->
1789 getAmode dst `thenNat` \ amode ->
1790 getRegister src `thenNat` \ register ->
1792 code1 = amodeCode amode
1793 dst__2 = amodeAddr amode
1794 code2 = registerCode register tmp
1795 src__2 = registerName register tmp
1796 sz = primRepToSize pk
1797 code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1801 assignIntCode pk dst src
1802 = getRegister dst `thenNat` \ register1 ->
1803 getRegister src `thenNat` \ register2 ->
1805 dst__2 = registerName register1 g0
1806 code = registerCode register2 dst__2
1807 src__2 = registerName register2 dst__2
1808 code__2 = if isFixed register2
1809 then code `snocOL` OR False g0 (RIReg src__2) dst__2
1814 #endif {- sparc_TARGET_ARCH -}
1817 % --------------------------------
1818 Floating-point assignments:
1819 % --------------------------------
1821 #if alpha_TARGET_ARCH
1823 assignFltCode pk (StInd _ dst) src
1824 = getNewRegNCG pk `thenNat` \ tmp ->
1825 getAmode dst `thenNat` \ amode ->
1826 getRegister src `thenNat` \ register ->
1828 code1 = amodeCode amode []
1829 dst__2 = amodeAddr amode
1830 code2 = registerCode register tmp []
1831 src__2 = registerName register tmp
1832 sz = primRepToSize pk
1833 code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1837 assignFltCode pk dst src
1838 = getRegister dst `thenNat` \ register1 ->
1839 getRegister src `thenNat` \ register2 ->
1841 dst__2 = registerName register1 zeroh
1842 code = registerCode register2 dst__2
1843 src__2 = registerName register2 dst__2
1844 code__2 = if isFixed register2
1845 then code . mkSeqInstr (FMOV src__2 dst__2)
1850 #endif {- alpha_TARGET_ARCH -}
1851 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1852 #if i386_TARGET_ARCH
1855 assignFltCode pk (StInd pk_dst addr) src
1857 = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1859 = getRegister src `thenNat` \ reg_src ->
1860 getRegister addr `thenNat` \ reg_addr ->
1861 getNewRegNCG pk `thenNat` \ tmp_src ->
1862 getNewRegNCG PtrRep `thenNat` \ tmp_addr ->
1863 let r_src = registerName reg_src tmp_src
1864 c_src = registerCode reg_src tmp_src
1865 r_addr = registerName reg_addr tmp_addr
1866 c_addr = registerCode reg_addr tmp_addr
1867 sz = primRepToSize pk
1869 code = c_src `appOL`
1870 -- no need to preserve r_src across the addr computation,
1871 -- since r_src must be a float reg
1872 -- whilst r_addr is an int reg
1875 (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1879 -- dst must be a (FP) register
1880 assignFltCode pk dst src
1881 = getRegister dst `thenNat` \ reg_dst ->
1882 getRegister src `thenNat` \ reg_src ->
1883 getNewRegNCG pk `thenNat` \ tmp ->
1885 r_dst = registerName reg_dst tmp
1886 c_dst = registerCode reg_dst tmp -- should be empty
1888 r_src = registerName reg_src r_dst
1889 c_src = registerCode reg_src r_dst
1891 code | isNilOL c_dst
1892 = if isFixed reg_src
1893 then c_src `snocOL` GMOV r_src r_dst
1896 = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1902 #endif {- i386_TARGET_ARCH -}
1903 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1904 #if sparc_TARGET_ARCH
1906 assignFltCode pk (StInd _ dst) src
1907 = getNewRegNCG pk `thenNat` \ tmp1 ->
1908 getAmode dst `thenNat` \ amode ->
1909 getRegister src `thenNat` \ register ->
1911 sz = primRepToSize pk
1912 dst__2 = amodeAddr amode
1914 code1 = amodeCode amode
1915 code2 = registerCode register tmp1
1917 src__2 = registerName register tmp1
1918 pk__2 = registerRep register
1919 sz__2 = primRepToSize pk__2
1921 code__2 = code1 `appOL` code2 `appOL`
1923 then unitOL (ST sz src__2 dst__2)
1924 else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1928 assignFltCode pk dst src
1929 = getRegister dst `thenNat` \ register1 ->
1930 getRegister src `thenNat` \ register2 ->
1932 pk__2 = registerRep register2
1933 sz__2 = primRepToSize pk__2
1935 getNewRegNCG pk__2 `thenNat` \ tmp ->
1937 sz = primRepToSize pk
1938 dst__2 = registerName register1 g0 -- must be Fixed
1941 reg__2 = if pk /= pk__2 then tmp else dst__2
1943 code = registerCode register2 reg__2
1945 src__2 = registerName register2 reg__2
1949 code `snocOL` FxTOy sz__2 sz src__2 dst__2
1950 else if isFixed register2 then
1951 code `snocOL` FMOV sz src__2 dst__2
1957 #endif {- sparc_TARGET_ARCH -}
1960 %************************************************************************
1962 \subsection{Generating an unconditional branch}
1964 %************************************************************************
1966 We accept two types of targets: an immediate CLabel or a tree that
1967 gets evaluated into a register. Any CLabels which are AsmTemporaries
1968 are assumed to be in the local block of code, close enough for a
1969 branch instruction. Other CLabels are assumed to be far away.
1971 (If applicable) Do not fill the delay slots here; you will confuse the
1975 genJump :: StixTree{-the branch target-} -> NatM InstrBlock
1977 #if alpha_TARGET_ARCH
1979 genJump (StCLbl lbl)
1980 | isAsmTemp lbl = returnInstr (BR target)
1981 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1983 target = ImmCLbl lbl
1986 = getRegister tree `thenNat` \ register ->
1987 getNewRegNCG PtrRep `thenNat` \ tmp ->
1989 dst = registerName register pv
1990 code = registerCode register pv
1991 target = registerName register pv
1993 if isFixed register then
1994 returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1996 returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1998 #endif {- alpha_TARGET_ARCH -}
1999 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2000 #if i386_TARGET_ARCH
2002 genJump (StInd pk mem)
2003 = getAmode mem `thenNat` \ amode ->
2005 code = amodeCode amode
2006 target = amodeAddr amode
2008 returnNat (code `snocOL` JMP (OpAddr target))
2012 = returnNat (unitOL (JMP (OpImm target)))
2015 = getRegister tree `thenNat` \ register ->
2016 getNewRegNCG PtrRep `thenNat` \ tmp ->
2018 code = registerCode register tmp
2019 target = registerName register tmp
2021 returnNat (code `snocOL` JMP (OpReg target))
2024 target = case imm of Just x -> x
2026 #endif {- i386_TARGET_ARCH -}
2027 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2028 #if sparc_TARGET_ARCH
2030 genJump (StCLbl lbl)
2031 | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP])
2032 | otherwise = returnNat (toOL [CALL target 0 True, NOP])
2034 target = ImmCLbl lbl
2037 = getRegister tree `thenNat` \ register ->
2038 getNewRegNCG PtrRep `thenNat` \ tmp ->
2040 code = registerCode register tmp
2041 target = registerName register tmp
2043 returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP)
2045 #endif {- sparc_TARGET_ARCH -}
2048 %************************************************************************
2050 \subsection{Conditional jumps}
2052 %************************************************************************
2054 Conditional jumps are always to local labels, so we can use branch
2055 instructions. We peek at the arguments to decide what kind of
2058 ALPHA: For comparisons with 0, we're laughing, because we can just do
2059 the desired conditional branch.
2061 I386: First, we have to ensure that the condition
2062 codes are set according to the supplied comparison operation.
2064 SPARC: First, we have to ensure that the condition codes are set
2065 according to the supplied comparison operation. We generate slightly
2066 different code for floating point comparisons, because a floating
2067 point operation cannot directly precede a @BF@. We assume the worst
2068 and fill that slot with a @NOP@.
2070 SPARC: Do not fill the delay slots here; you will confuse the register
2075 :: CLabel -- the branch target
2076 -> StixTree -- the condition on which to branch
2079 #if alpha_TARGET_ARCH
2081 genCondJump lbl (StPrim op [x, StInt 0])
2082 = getRegister x `thenNat` \ register ->
2083 getNewRegNCG (registerRep register)
2086 code = registerCode register tmp
2087 value = registerName register tmp
2088 pk = registerRep register
2089 target = ImmCLbl lbl
2091 returnSeq code [BI (cmpOp op) value target]
2093 cmpOp CharGtOp = GTT
2095 cmpOp CharEqOp = EQQ
2097 cmpOp CharLtOp = LTT
2106 cmpOp WordGeOp = ALWAYS
2107 cmpOp WordEqOp = EQQ
2109 cmpOp WordLtOp = NEVER
2110 cmpOp WordLeOp = EQQ
2112 cmpOp AddrGeOp = ALWAYS
2113 cmpOp AddrEqOp = EQQ
2115 cmpOp AddrLtOp = NEVER
2116 cmpOp AddrLeOp = EQQ
2118 genCondJump lbl (StPrim op [x, StDouble 0.0])
2119 = getRegister x `thenNat` \ register ->
2120 getNewRegNCG (registerRep register)
2123 code = registerCode register tmp
2124 value = registerName register tmp
2125 pk = registerRep register
2126 target = ImmCLbl lbl
2128 returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2130 cmpOp FloatGtOp = GTT
2131 cmpOp FloatGeOp = GE
2132 cmpOp FloatEqOp = EQQ
2133 cmpOp FloatNeOp = NE
2134 cmpOp FloatLtOp = LTT
2135 cmpOp FloatLeOp = LE
2136 cmpOp DoubleGtOp = GTT
2137 cmpOp DoubleGeOp = GE
2138 cmpOp DoubleEqOp = EQQ
2139 cmpOp DoubleNeOp = NE
2140 cmpOp DoubleLtOp = LTT
2141 cmpOp DoubleLeOp = LE
2143 genCondJump lbl (StPrim op [x, y])
2145 = trivialFCode pr instr x y `thenNat` \ register ->
2146 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2148 code = registerCode register tmp
2149 result = registerName register tmp
2150 target = ImmCLbl lbl
2152 returnNat (code . mkSeqInstr (BF cond result target))
2154 pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2156 fltCmpOp op = case op of
2170 (instr, cond) = case op of
2171 FloatGtOp -> (FCMP TF LE, EQQ)
2172 FloatGeOp -> (FCMP TF LTT, EQQ)
2173 FloatEqOp -> (FCMP TF EQQ, NE)
2174 FloatNeOp -> (FCMP TF EQQ, EQQ)
2175 FloatLtOp -> (FCMP TF LTT, NE)
2176 FloatLeOp -> (FCMP TF LE, NE)
2177 DoubleGtOp -> (FCMP TF LE, EQQ)
2178 DoubleGeOp -> (FCMP TF LTT, EQQ)
2179 DoubleEqOp -> (FCMP TF EQQ, NE)
2180 DoubleNeOp -> (FCMP TF EQQ, EQQ)
2181 DoubleLtOp -> (FCMP TF LTT, NE)
2182 DoubleLeOp -> (FCMP TF LE, NE)
2184 genCondJump lbl (StPrim op [x, y])
2185 = trivialCode instr x y `thenNat` \ register ->
2186 getNewRegNCG IntRep `thenNat` \ tmp ->
2188 code = registerCode register tmp
2189 result = registerName register tmp
2190 target = ImmCLbl lbl
2192 returnNat (code . mkSeqInstr (BI cond result target))
2194 (instr, cond) = case op of
2195 CharGtOp -> (CMP LE, EQQ)
2196 CharGeOp -> (CMP LTT, EQQ)
2197 CharEqOp -> (CMP EQQ, NE)
2198 CharNeOp -> (CMP EQQ, EQQ)
2199 CharLtOp -> (CMP LTT, NE)
2200 CharLeOp -> (CMP LE, NE)
2201 IntGtOp -> (CMP LE, EQQ)
2202 IntGeOp -> (CMP LTT, EQQ)
2203 IntEqOp -> (CMP EQQ, NE)
2204 IntNeOp -> (CMP EQQ, EQQ)
2205 IntLtOp -> (CMP LTT, NE)
2206 IntLeOp -> (CMP LE, NE)
2207 WordGtOp -> (CMP ULE, EQQ)
2208 WordGeOp -> (CMP ULT, EQQ)
2209 WordEqOp -> (CMP EQQ, NE)
2210 WordNeOp -> (CMP EQQ, EQQ)
2211 WordLtOp -> (CMP ULT, NE)
2212 WordLeOp -> (CMP ULE, NE)
2213 AddrGtOp -> (CMP ULE, EQQ)
2214 AddrGeOp -> (CMP ULT, EQQ)
2215 AddrEqOp -> (CMP EQQ, NE)
2216 AddrNeOp -> (CMP EQQ, EQQ)
2217 AddrLtOp -> (CMP ULT, NE)
2218 AddrLeOp -> (CMP ULE, NE)
2220 #endif {- alpha_TARGET_ARCH -}
2221 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2222 #if i386_TARGET_ARCH
2224 genCondJump lbl bool
2225 = getCondCode bool `thenNat` \ condition ->
2227 code = condCode condition
2228 cond = condName condition
2229 target = ImmCLbl lbl
2231 returnNat (code `snocOL` JXX cond lbl)
2233 #endif {- i386_TARGET_ARCH -}
2234 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2235 #if sparc_TARGET_ARCH
2237 genCondJump lbl bool
2238 = getCondCode bool `thenNat` \ condition ->
2240 code = condCode condition
2241 cond = condName condition
2242 target = ImmCLbl lbl
2247 if condFloat condition
2248 then [NOP, BF cond False target, NOP]
2249 else [BI cond False target, NOP]
2253 #endif {- sparc_TARGET_ARCH -}
2256 %************************************************************************
2258 \subsection{Generating C calls}
2260 %************************************************************************
2262 Now the biggest nightmare---calls. Most of the nastiness is buried in
2263 @get_arg@, which moves the arguments to the correct registers/stack
2264 locations. Apart from that, the code is easy.
2266 (If applicable) Do not fill the delay slots here; you will confuse the
2271 :: FAST_STRING -- function to call
2273 -> PrimRep -- type of the result
2274 -> [StixTree] -- arguments (of mixed type)
2277 #if alpha_TARGET_ARCH
2279 genCCall fn cconv kind args
2280 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2281 `thenNat` \ ((unused,_), argCode) ->
2283 nRegs = length allArgRegs - length unused
2284 code = asmSeqThen (map ($ []) argCode)
2287 LDA pv (AddrImm (ImmLab (ptext fn))),
2288 JSR ra (AddrReg pv) nRegs,
2289 LDGP gp (AddrReg ra)]
2291 ------------------------
2292 {- Try to get a value into a specific register (or registers) for
2293 a call. The first 6 arguments go into the appropriate
2294 argument register (separate registers for integer and floating
2295 point arguments, but used in lock-step), and the remaining
2296 arguments are dumped to the stack, beginning at 0(sp). Our
2297 first argument is a pair of the list of remaining argument
2298 registers to be assigned for this call and the next stack
2299 offset to use for overflowing arguments. This way,
2300 @get_Arg@ can be applied to all of a call's arguments using
2304 :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
2305 -> StixTree -- Current argument
2306 -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2308 -- We have to use up all of our argument registers first...
2310 get_arg ((iDst,fDst):dsts, offset) arg
2311 = getRegister arg `thenNat` \ register ->
2313 reg = if isFloatingRep pk then fDst else iDst
2314 code = registerCode register reg
2315 src = registerName register reg
2316 pk = registerRep register
2319 if isFloatingRep pk then
2320 ((dsts, offset), if isFixed register then
2321 code . mkSeqInstr (FMOV src fDst)
2324 ((dsts, offset), if isFixed register then
2325 code . mkSeqInstr (OR src (RIReg src) iDst)
2328 -- Once we have run out of argument registers, we move to the
2331 get_arg ([], offset) arg
2332 = getRegister arg `thenNat` \ register ->
2333 getNewRegNCG (registerRep register)
2336 code = registerCode register tmp
2337 src = registerName register tmp
2338 pk = registerRep register
2339 sz = primRepToSize pk
2341 returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2343 #endif {- alpha_TARGET_ARCH -}
2344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2345 #if i386_TARGET_ARCH
2347 genCCall fn cconv kind [StInt i]
2348 | fn == SLIT ("PerformGC_wrapper")
2350 MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2351 CALL (ImmLit (ptext (if underscorePrefix
2352 then (SLIT ("_PerformGC_wrapper"))
2353 else (SLIT ("PerformGC_wrapper")))))
2359 genCCall fn cconv kind args
2360 = mapNat get_call_arg
2361 (reverse args) `thenNat` \ sizes_n_codes ->
2362 getDeltaNat `thenNat` \ delta ->
2363 let (sizes, codes) = unzip sizes_n_codes
2364 tot_arg_size = sum sizes
2365 code2 = concatOL codes
2368 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2369 DELTA (delta + tot_arg_size)
2372 setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2373 returnNat (code2 `appOL` call)
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 False (ptext fn)
2389 get_call_arg :: StixTree{-current argument-}
2390 -> NatM (Int, InstrBlock) -- argsz, code
2393 = get_op arg `thenNat` \ (code, reg, sz) ->
2394 getDeltaNat `thenNat` \ delta ->
2395 arg_size sz `bind` \ size ->
2396 setDeltaNat (delta-size) `thenNat` \ _ ->
2397 if (case sz of DF -> True; F -> True; _ -> False)
2398 then returnNat (size,
2400 toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp),
2402 GST DF reg (AddrBaseIndex (Just esp)
2406 else returnNat (size,
2408 PUSH L (OpReg reg) `snocOL`
2414 -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2417 = getRegister op `thenNat` \ register ->
2418 getNewRegNCG (registerRep register)
2421 code = registerCode register tmp
2422 reg = registerName register tmp
2423 pk = registerRep register
2424 sz = primRepToSize pk
2426 returnNat (code, reg, sz)
2428 #endif {- i386_TARGET_ARCH -}
2429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2430 #if sparc_TARGET_ARCH
2431 genCCall fn cconv kind args
2432 = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2433 `thenNat` \ ((unused,_), argCode) ->
2436 nRegs = length allArgRegs - length unused
2437 call = unitOL (CALL fn__2 nRegs False)
2438 code = concatOL argCode
2440 -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args
2441 (move_sp_down, move_sp_up)
2442 = let nn = length args - 3
2445 else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn)))
2447 returnNat (move_sp_down `appOL`
2453 -- function names that begin with '.' are assumed to be special
2454 -- internally generated names like '.mul,' which don't get an
2455 -- underscore prefix
2456 -- ToDo:needed (WDP 96/03) ???
2457 fn__2 = case (_HEAD_ fn) of
2458 '.' -> ImmLit (ptext fn)
2459 _ -> ImmLab False (ptext fn)
2461 ------------------------------------
2462 {- Try to get a value into a specific register (or registers) for
2463 a call. The SPARC calling convention is an absolute
2464 nightmare. The first 6x32 bits of arguments are mapped into
2465 %o0 through %o5, and the remaining arguments are dumped to the
2466 stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our
2467 first argument is a pair of the list of remaining argument
2468 registers to be assigned for this call and the next stack
2469 offset to use for overflowing arguments. This way,
2470 @get_arg@ can be applied to all of a call's arguments using
2473 If we have to put args on the stack, move %o6==%sp down by
2474 8 x the number of args, to ensure there's enough space.
2477 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
2478 -> StixTree -- Current argument
2479 -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2481 -- We have to use up all of our argument registers first...
2483 get_arg (dst:dsts, offset) arg
2484 = getRegister arg `thenNat` \ register ->
2485 getNewRegNCG (registerRep register)
2488 reg = if isFloatingRep pk then tmp else dst
2489 code = registerCode register reg
2490 src = registerName register reg
2491 pk = registerRep register
2497 [] -> ( ([], offset + 1),
2499 -- put the second part in the right stack
2500 -- and load the first part into %o5
2501 FMOV DF src f0 `snocOL`
2502 ST F f0 (spRel offset) `snocOL`
2503 LD W (spRel offset) dst `snocOL`
2504 ST F (fPair f0) (spRel offset)
2507 -> ( (dsts__2, offset),
2509 FMOV DF src f0 `snocOL`
2510 ST F f0 (spRel 16) `snocOL`
2511 LD W (spRel 16) dst `snocOL`
2512 ST F (fPair f0) (spRel 16) `snocOL`
2513 LD W (spRel 16) dst__2
2516 -> ( (dsts, offset),
2518 ST F src (spRel 16) `snocOL`
2521 _ -> ( (dsts, offset),
2523 then code `snocOL` OR False g0 (RIReg src) dst
2527 -- Once we have run out of argument registers, we move to the
2530 get_arg ([], offset) arg
2531 = getRegister arg `thenNat` \ register ->
2532 getNewRegNCG (registerRep register)
2535 code = registerCode register tmp
2536 src = registerName register tmp
2537 pk = registerRep register
2538 sz = primRepToSize pk
2539 words = if pk == DoubleRep then 2 else 1
2541 returnNat ( ([], offset + words),
2542 code `snocOL` ST sz src (spRel offset) )
2544 #endif {- sparc_TARGET_ARCH -}
2547 %************************************************************************
2549 \subsection{Support bits}
2551 %************************************************************************
2553 %************************************************************************
2555 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2557 %************************************************************************
2559 Turn those condition codes into integers now (when they appear on
2560 the right hand side of an assignment).
2562 (If applicable) Do not fill the delay slots here; you will confuse the
2566 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2568 #if alpha_TARGET_ARCH
2569 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2570 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2571 #endif {- alpha_TARGET_ARCH -}
2573 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2574 #if i386_TARGET_ARCH
2577 = condIntCode cond x y `thenNat` \ condition ->
2578 getNewRegNCG IntRep `thenNat` \ tmp ->
2580 code = condCode condition
2581 cond = condName condition
2582 code__2 dst = code `appOL` toOL [
2583 SETCC cond (OpReg tmp),
2584 AND L (OpImm (ImmInt 1)) (OpReg tmp),
2585 MOV L (OpReg tmp) (OpReg 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 `appOL` toOL [
2598 MOV L (OpImm (ImmInt 0)) (OpReg dst),
2601 MOV L (OpImm (ImmInt 1)) (OpReg dst),
2604 returnNat (Any IntRep code__2)
2606 #endif {- i386_TARGET_ARCH -}
2607 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2608 #if sparc_TARGET_ARCH
2610 condIntReg EQQ x (StInt 0)
2611 = getRegister x `thenNat` \ register ->
2612 getNewRegNCG IntRep `thenNat` \ tmp ->
2614 code = registerCode register tmp
2615 src = registerName register tmp
2616 code__2 dst = code `appOL` toOL [
2617 SUB False True g0 (RIReg src) g0,
2618 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2620 returnNat (Any IntRep code__2)
2623 = getRegister x `thenNat` \ register1 ->
2624 getRegister y `thenNat` \ register2 ->
2625 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2626 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2628 code1 = registerCode register1 tmp1
2629 src1 = registerName register1 tmp1
2630 code2 = registerCode register2 tmp2
2631 src2 = registerName register2 tmp2
2632 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2633 XOR False src1 (RIReg src2) dst,
2634 SUB False True g0 (RIReg dst) g0,
2635 SUB True False g0 (RIImm (ImmInt (-1))) dst]
2637 returnNat (Any IntRep code__2)
2639 condIntReg NE x (StInt 0)
2640 = getRegister x `thenNat` \ register ->
2641 getNewRegNCG IntRep `thenNat` \ tmp ->
2643 code = registerCode register tmp
2644 src = registerName register tmp
2645 code__2 dst = code `appOL` toOL [
2646 SUB False True g0 (RIReg src) g0,
2647 ADD True False g0 (RIImm (ImmInt 0)) dst]
2649 returnNat (Any IntRep code__2)
2652 = getRegister x `thenNat` \ register1 ->
2653 getRegister y `thenNat` \ register2 ->
2654 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2655 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2657 code1 = registerCode register1 tmp1
2658 src1 = registerName register1 tmp1
2659 code2 = registerCode register2 tmp2
2660 src2 = registerName register2 tmp2
2661 code__2 dst = code1 `appOL` code2 `appOL` toOL [
2662 XOR False src1 (RIReg src2) dst,
2663 SUB False True g0 (RIReg dst) g0,
2664 ADD True False g0 (RIImm (ImmInt 0)) dst]
2666 returnNat (Any IntRep code__2)
2669 = getNatLabelNCG `thenNat` \ lbl1 ->
2670 getNatLabelNCG `thenNat` \ lbl2 ->
2671 condIntCode cond x y `thenNat` \ condition ->
2673 code = condCode condition
2674 cond = condName condition
2675 code__2 dst = code `appOL` toOL [
2676 BI cond False (ImmCLbl lbl1), NOP,
2677 OR False g0 (RIImm (ImmInt 0)) dst,
2678 BI ALWAYS False (ImmCLbl lbl2), NOP,
2680 OR False g0 (RIImm (ImmInt 1)) dst,
2683 returnNat (Any IntRep code__2)
2686 = getNatLabelNCG `thenNat` \ lbl1 ->
2687 getNatLabelNCG `thenNat` \ lbl2 ->
2688 condFltCode cond x y `thenNat` \ condition ->
2690 code = condCode condition
2691 cond = condName condition
2692 code__2 dst = code `appOL` toOL [
2694 BF 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)
2703 #endif {- sparc_TARGET_ARCH -}
2706 %************************************************************************
2708 \subsubsection{@trivial*Code@: deal with trivial instructions}
2710 %************************************************************************
2712 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2713 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look
2714 for constants on the right hand side, because that's where the generic
2715 optimizer will have put them.
2717 Similarly, for unary instructions, we don't have to worry about
2718 matching an StInt as the argument, because genericOpt will already
2719 have handled the constant-folding.
2723 :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2724 ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2725 -> Maybe (Operand -> Operand -> Instr)
2726 ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2728 -> StixTree -> StixTree -- the two arguments
2733 -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2734 ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2735 ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2737 -> StixTree -> StixTree -- the two arguments
2741 :: IF_ARCH_alpha((RI -> Reg -> Instr)
2742 ,IF_ARCH_i386 ((Operand -> Instr)
2743 ,IF_ARCH_sparc((RI -> Reg -> Instr)
2745 -> StixTree -- the one argument
2750 -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2751 ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2752 ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2754 -> StixTree -- the one argument
2757 #if alpha_TARGET_ARCH
2759 trivialCode instr x (StInt y)
2761 = getRegister x `thenNat` \ register ->
2762 getNewRegNCG IntRep `thenNat` \ tmp ->
2764 code = registerCode register tmp
2765 src1 = registerName register tmp
2766 src2 = ImmInt (fromInteger y)
2767 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2769 returnNat (Any IntRep code__2)
2771 trivialCode instr x y
2772 = getRegister x `thenNat` \ register1 ->
2773 getRegister y `thenNat` \ register2 ->
2774 getNewRegNCG IntRep `thenNat` \ tmp1 ->
2775 getNewRegNCG IntRep `thenNat` \ tmp2 ->
2777 code1 = registerCode register1 tmp1 []
2778 src1 = registerName register1 tmp1
2779 code2 = registerCode register2 tmp2 []
2780 src2 = registerName register2 tmp2
2781 code__2 dst = asmSeqThen [code1, code2] .
2782 mkSeqInstr (instr src1 (RIReg src2) dst)
2784 returnNat (Any IntRep code__2)
2787 trivialUCode instr x
2788 = getRegister x `thenNat` \ register ->
2789 getNewRegNCG IntRep `thenNat` \ tmp ->
2791 code = registerCode register tmp
2792 src = registerName register tmp
2793 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2795 returnNat (Any IntRep code__2)
2798 trivialFCode _ instr x y
2799 = getRegister x `thenNat` \ register1 ->
2800 getRegister y `thenNat` \ register2 ->
2801 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2802 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2804 code1 = registerCode register1 tmp1
2805 src1 = registerName register1 tmp1
2807 code2 = registerCode register2 tmp2
2808 src2 = registerName register2 tmp2
2810 code__2 dst = asmSeqThen [code1 [], code2 []] .
2811 mkSeqInstr (instr src1 src2 dst)
2813 returnNat (Any DoubleRep code__2)
2815 trivialUFCode _ instr x
2816 = getRegister x `thenNat` \ register ->
2817 getNewRegNCG DoubleRep `thenNat` \ tmp ->
2819 code = registerCode register tmp
2820 src = registerName register tmp
2821 code__2 dst = code . mkSeqInstr (instr src dst)
2823 returnNat (Any DoubleRep code__2)
2825 #endif {- alpha_TARGET_ARCH -}
2826 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2827 #if i386_TARGET_ARCH
2829 The Rules of the Game are:
2831 * You cannot assume anything about the destination register dst;
2832 it may be anything, including a fixed reg.
2834 * You may compute an operand into a fixed reg, but you may not
2835 subsequently change the contents of that fixed reg. If you
2836 want to do so, first copy the value either to a temporary
2837 or into dst. You are free to modify dst even if it happens
2838 to be a fixed reg -- that's not your problem.
2840 * You cannot assume that a fixed reg will stay live over an
2841 arbitrary computation. The same applies to the dst reg.
2843 * Temporary regs obtained from getNewRegNCG are distinct from
2844 each other and from all other regs, and stay live over
2845 arbitrary computations.
2849 trivialCode instr maybe_revinstr a b
2852 = getRegister a `thenNat` \ rega ->
2855 then registerCode rega dst `bind` \ code_a ->
2857 instr (OpImm imm_b) (OpReg dst)
2858 else registerCodeF rega `bind` \ code_a ->
2859 registerNameF rega `bind` \ r_a ->
2861 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2862 instr (OpImm imm_b) (OpReg dst)
2864 returnNat (Any IntRep mkcode)
2867 = getRegister b `thenNat` \ regb ->
2868 getNewRegNCG IntRep `thenNat` \ tmp ->
2869 let revinstr_avail = maybeToBool maybe_revinstr
2870 revinstr = case maybe_revinstr of Just ri -> ri
2874 then registerCode regb dst `bind` \ code_b ->
2876 revinstr (OpImm imm_a) (OpReg dst)
2877 else registerCodeF regb `bind` \ code_b ->
2878 registerNameF regb `bind` \ r_b ->
2880 MOV L (OpReg r_b) (OpReg dst) `snocOL`
2881 revinstr (OpImm imm_a) (OpReg dst)
2885 then registerCode regb tmp `bind` \ code_b ->
2887 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2888 instr (OpReg tmp) (OpReg dst)
2889 else registerCodeF regb `bind` \ code_b ->
2890 registerNameF regb `bind` \ r_b ->
2892 MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2893 MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2894 instr (OpReg tmp) (OpReg dst)
2896 returnNat (Any IntRep mkcode)
2899 = getRegister a `thenNat` \ rega ->
2900 getRegister b `thenNat` \ regb ->
2901 getNewRegNCG IntRep `thenNat` \ tmp ->
2903 = case (isAny rega, isAny regb) of
2905 -> registerCode regb tmp `bind` \ code_b ->
2906 registerCode rega dst `bind` \ code_a ->
2909 instr (OpReg tmp) (OpReg dst)
2911 -> registerCode rega tmp `bind` \ code_a ->
2912 registerCodeF regb `bind` \ code_b ->
2913 registerNameF regb `bind` \ r_b ->
2916 instr (OpReg r_b) (OpReg tmp) `snocOL`
2917 MOV L (OpReg tmp) (OpReg dst)
2919 -> registerCode regb tmp `bind` \ code_b ->
2920 registerCodeF rega `bind` \ code_a ->
2921 registerNameF rega `bind` \ r_a ->
2924 MOV L (OpReg r_a) (OpReg dst) `snocOL`
2925 instr (OpReg tmp) (OpReg dst)
2927 -> registerCodeF rega `bind` \ code_a ->
2928 registerNameF rega `bind` \ r_a ->
2929 registerCodeF regb `bind` \ code_b ->
2930 registerNameF regb `bind` \ r_b ->
2932 MOV L (OpReg r_a) (OpReg tmp) `appOL`
2934 instr (OpReg r_b) (OpReg tmp) `snocOL`
2935 MOV L (OpReg tmp) (OpReg dst)
2937 returnNat (Any IntRep mkcode)
2940 maybe_imm_a = maybeImm a
2941 is_imm_a = maybeToBool maybe_imm_a
2942 imm_a = case maybe_imm_a of Just imm -> imm
2944 maybe_imm_b = maybeImm b
2945 is_imm_b = maybeToBool maybe_imm_b
2946 imm_b = case maybe_imm_b of Just imm -> imm
2950 trivialUCode instr x
2951 = getRegister x `thenNat` \ register ->
2953 code__2 dst = let code = registerCode register dst
2954 src = registerName register dst
2956 if isFixed register && dst /= src
2957 then toOL [MOV L (OpReg src) (OpReg dst),
2959 else unitOL (instr (OpReg src))
2961 returnNat (Any IntRep code__2)
2964 trivialFCode pk instr x y
2965 = getRegister x `thenNat` \ register1 ->
2966 getRegister y `thenNat` \ register2 ->
2967 getNewRegNCG DoubleRep `thenNat` \ tmp1 ->
2968 getNewRegNCG DoubleRep `thenNat` \ tmp2 ->
2970 code1 = registerCode register1 tmp1
2971 src1 = registerName register1 tmp1
2973 code2 = registerCode register2 tmp2
2974 src2 = registerName register2 tmp2
2977 -- treat the common case specially: both operands in
2979 | isAny register1 && isAny register2
2982 instr (primRepToSize pk) src1 src2 dst
2984 -- be paranoid (and inefficient)
2986 = code1 `snocOL` GMOV src1 tmp1 `appOL`
2988 instr (primRepToSize pk) tmp1 src2 dst
2990 returnNat (Any DoubleRep code__2)
2994 trivialUFCode pk instr x
2995 = getRegister x `thenNat` \ register ->
2996 getNewRegNCG pk `thenNat` \ tmp ->
2998 code = registerCode register tmp
2999 src = registerName register tmp
3000 code__2 dst = code `snocOL` instr src dst
3002 returnNat (Any pk code__2)
3004 #endif {- i386_TARGET_ARCH -}
3005 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3006 #if sparc_TARGET_ARCH
3008 trivialCode instr x (StInt y)
3010 = getRegister x `thenNat` \ register ->
3011 getNewRegNCG IntRep `thenNat` \ tmp ->
3013 code = registerCode register tmp
3014 src1 = registerName register tmp
3015 src2 = ImmInt (fromInteger y)
3016 code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3018 returnNat (Any IntRep code__2)
3020 trivialCode instr x y
3021 = getRegister x `thenNat` \ register1 ->
3022 getRegister y `thenNat` \ register2 ->
3023 getNewRegNCG IntRep `thenNat` \ tmp1 ->
3024 getNewRegNCG IntRep `thenNat` \ tmp2 ->
3026 code1 = registerCode register1 tmp1
3027 src1 = registerName register1 tmp1
3028 code2 = registerCode register2 tmp2
3029 src2 = registerName register2 tmp2
3030 code__2 dst = code1 `appOL` code2 `snocOL`
3031 instr src1 (RIReg src2) dst
3033 returnNat (Any IntRep code__2)
3036 trivialFCode pk instr x y
3037 = getRegister x `thenNat` \ register1 ->
3038 getRegister y `thenNat` \ register2 ->
3039 getNewRegNCG (registerRep register1)
3041 getNewRegNCG (registerRep register2)
3043 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3045 promote x = FxTOy F DF x tmp
3047 pk1 = registerRep register1
3048 code1 = registerCode register1 tmp1
3049 src1 = registerName register1 tmp1
3051 pk2 = registerRep register2
3052 code2 = registerCode register2 tmp2
3053 src2 = registerName register2 tmp2
3057 code1 `appOL` code2 `snocOL`
3058 instr (primRepToSize pk) src1 src2 dst
3059 else if pk1 == FloatRep then
3060 code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3061 instr DF tmp src2 dst
3063 code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3064 instr DF src1 tmp dst
3066 returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3069 trivialUCode instr x
3070 = getRegister x `thenNat` \ register ->
3071 getNewRegNCG IntRep `thenNat` \ tmp ->
3073 code = registerCode register tmp
3074 src = registerName register tmp
3075 code__2 dst = code `snocOL` instr (RIReg src) dst
3077 returnNat (Any IntRep code__2)
3080 trivialUFCode pk instr x
3081 = getRegister x `thenNat` \ register ->
3082 getNewRegNCG pk `thenNat` \ tmp ->
3084 code = registerCode register tmp
3085 src = registerName register tmp
3086 code__2 dst = code `snocOL` instr src dst
3088 returnNat (Any pk code__2)
3090 #endif {- sparc_TARGET_ARCH -}
3093 %************************************************************************
3095 \subsubsection{Coercing to/from integer/floating-point...}
3097 %************************************************************************
3099 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3100 to be generated. Here we just change the type on the Register passed
3101 on up. The code is machine-independent.
3103 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3104 conversions. We have to store temporaries in memory to move
3105 between the integer and the floating point register sets.
3108 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3109 coerceFltCode :: StixTree -> NatM Register
3111 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3112 coerceFP2Int :: StixTree -> NatM Register
3115 = getRegister x `thenNat` \ register ->
3118 Fixed _ reg code -> Fixed pk reg code
3119 Any _ code -> Any pk code
3124 = getRegister x `thenNat` \ register ->
3127 Fixed _ reg code -> Fixed DoubleRep reg code
3128 Any _ code -> Any DoubleRep code
3133 #if alpha_TARGET_ARCH
3136 = getRegister x `thenNat` \ register ->
3137 getNewRegNCG IntRep `thenNat` \ reg ->
3139 code = registerCode register reg
3140 src = registerName register reg
3142 code__2 dst = code . mkSeqInstrs [
3144 LD TF dst (spRel 0),
3147 returnNat (Any DoubleRep code__2)
3151 = getRegister x `thenNat` \ register ->
3152 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3154 code = registerCode register tmp
3155 src = registerName register tmp
3157 code__2 dst = code . mkSeqInstrs [
3159 ST TF tmp (spRel 0),
3162 returnNat (Any IntRep code__2)
3164 #endif {- alpha_TARGET_ARCH -}
3165 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3166 #if i386_TARGET_ARCH
3169 = getRegister x `thenNat` \ register ->
3170 getNewRegNCG IntRep `thenNat` \ reg ->
3172 code = registerCode register reg
3173 src = registerName register reg
3174 opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3175 code__2 dst = code `snocOL` opc src dst
3177 returnNat (Any pk code__2)
3181 = getRegister x `thenNat` \ register ->
3182 getNewRegNCG DoubleRep `thenNat` \ tmp ->
3184 code = registerCode register tmp
3185 src = registerName register tmp
3186 pk = registerRep register
3188 opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3189 code__2 dst = code `snocOL` opc src dst
3191 returnNat (Any IntRep code__2)
3193 #endif {- i386_TARGET_ARCH -}
3194 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3195 #if sparc_TARGET_ARCH
3198 = getRegister x `thenNat` \ register ->
3199 getNewRegNCG IntRep `thenNat` \ reg ->
3201 code = registerCode register reg
3202 src = registerName register reg
3204 code__2 dst = code `appOL` toOL [
3205 ST W src (spRel (-2)),
3206 LD W (spRel (-2)) dst,
3207 FxTOy W (primRepToSize pk) dst dst]
3209 returnNat (Any pk code__2)
3213 = getRegister x `thenNat` \ register ->
3214 getNewRegNCG IntRep `thenNat` \ reg ->
3215 getNewRegNCG FloatRep `thenNat` \ tmp ->
3217 code = registerCode register reg
3218 src = registerName register reg
3219 pk = registerRep register
3221 code__2 dst = code `appOL` toOL [
3222 FxTOy (primRepToSize pk) W src tmp,
3223 ST W tmp (spRel (-2)),
3224 LD W (spRel (-2)) dst]
3226 returnNat (Any IntRep code__2)
3228 #endif {- sparc_TARGET_ARCH -}
3231 %************************************************************************
3233 \subsubsection{Coercing integer to @Char@...}
3235 %************************************************************************
3237 Integer to character conversion. Where applicable, we try to do this
3238 in one step if the original object is in memory.
3241 chrCode :: StixTree -> NatM Register
3243 #if alpha_TARGET_ARCH
3246 = getRegister x `thenNat` \ register ->
3247 getNewRegNCG IntRep `thenNat` \ reg ->
3249 code = registerCode register reg
3250 src = registerName register reg
3251 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3253 returnNat (Any IntRep code__2)
3255 #endif {- alpha_TARGET_ARCH -}
3256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257 #if i386_TARGET_ARCH
3260 = getRegister x `thenNat` \ register ->
3263 code = registerCode register dst
3264 src = registerName register dst
3266 if isFixed register && src /= dst
3267 then toOL [MOV L (OpReg src) (OpReg dst),
3268 AND L (OpImm (ImmInt 255)) (OpReg dst)]
3269 else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3271 returnNat (Any IntRep code__2)
3273 #endif {- i386_TARGET_ARCH -}
3274 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3275 #if sparc_TARGET_ARCH
3277 chrCode (StInd pk mem)
3278 = getAmode mem `thenNat` \ amode ->
3280 code = amodeCode amode
3281 src = amodeAddr amode
3282 src_off = addrOffset src 3
3283 src__2 = case src_off of Just x -> x
3284 code__2 dst = if maybeToBool src_off then
3285 code `snocOL` LD BU src__2 dst
3288 LD (primRepToSize pk) src dst `snocOL`
3289 AND False dst (RIImm (ImmInt 255)) dst
3291 returnNat (Any pk code__2)
3294 = getRegister x `thenNat` \ register ->
3295 getNewRegNCG IntRep `thenNat` \ reg ->
3297 code = registerCode register reg
3298 src = registerName register reg
3299 code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
3301 returnNat (Any IntRep code__2)
3303 #endif {- sparc_TARGET_ARCH -}